seriation/0000755000176200001440000000000014610044272012247 5ustar liggesusersseriation/NAMESPACE0000644000176200001440000000675214456056357013517 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method("[",ser_permutation) S3method(c,ser_permutation) S3method(c,ser_permutation_vector) S3method(criterion,array) S3method(criterion,data.frame) S3method(criterion,default) S3method(criterion,dist) S3method(criterion,matrix) S3method(criterion,table) S3method(get_order,default) S3method(get_order,dendrogram) S3method(get_order,hclust) S3method(get_order,integer) S3method(get_order,numeric) S3method(get_order,ser_permutation) S3method(get_order,ser_permutation_vector) S3method(ggpimage,default) S3method(ggpimage,dist) S3method(ggpimage,matrix) S3method(length,ser_permutation_vector) S3method(permute,array) S3method(permute,character) S3method(permute,data.frame) S3method(permute,default) S3method(permute,dendrogram) S3method(permute,dist) S3method(permute,hclust) S3method(permute,list) S3method(permute,matrix) S3method(permute,numeric) S3method(permute,table) S3method(pimage,data.frame) S3method(pimage,default) S3method(pimage,dist) S3method(pimage,matrix) S3method(pimage,table) S3method(plot,reordered_cluster_dissimilarity_matrix) S3method(print,criterion_method) S3method(print,reordered_cluster_dissimilarity_matrix) S3method(print,ser_permutation) S3method(print,ser_permutation_vector) S3method(print,seriation_method) S3method(reorder,hclust) S3method(rev,ser_permutation_vector) S3method(seriate,array) S3method(seriate,data.frame) S3method(seriate,default) S3method(seriate,dist) S3method(seriate,matrix) S3method(seriate,table) S3method(summary,ser_permutation) S3method(summary,ser_permutation_vector) export(LS_insert) export(LS_mixed) export(LS_reverse) export(LS_swap) export(MDS_stress) export(VAT) export(bertin_cut_line) export(bertinplot) export(bluered) export(blues) export(create_lines_data) export(create_ordered_data) export(criterion) export(dissplot) export(gaperm_mixedMutation) export(get_config) export(get_criterion_method) export(get_method) export(get_order) export(get_permutation_matrix) export(get_rank) export(get_seriation_method) export(ggVAT) export(ggbertinplot) export(ggdissplot) export(gghmap) export(ggiVAT) export(ggpimage) export(grays) export(greenred) export(greens) export(greys) export(hmap) export(iVAT) export(is.robinson) export(list_criterion_methods) export(list_seriation_methods) export(lle) export(panel.bars) export(panel.blocks) export(panel.circles) export(panel.lines) export(panel.rectangles) export(panel.squares) export(panel.tiles) export(path_dist) export(permutation_matrix2vector) export(permutation_vector2matrix) export(permute) export(pimage) export(plot_config) export(random.robinson) export(reds) export(register_DendSer) export(register_GA) export(register_optics) export(register_smacof) export(register_tsne) export(register_umap) export(registry_criterion) export(registry_seriate) export(ser_align) export(ser_cor) export(ser_dist) export(ser_permutation) export(ser_permutation_vector) export(seriate) export(seriate_best) export(seriate_improve) export(seriate_rep) export(set_criterion_method) export(set_seriation_method) export(uniscale) import("TSP") import("grid") import(registry) importFrom(ca,ca) importFrom(foreach,`%do%`) importFrom(foreach,`%dopar%`) importFrom(foreach,times) importFrom(graphics,plot) importFrom(graphics,text) importFrom(graphics,title) importFrom(stats,as.dist) importFrom(stats,dist) importFrom(stats,hclust) importFrom(stats,order.dendrogram) importFrom(stats,prcomp) importFrom(stats,reorder) importFrom(stats,rnorm) importFrom(stats,runif) useDynLib(seriation, .registration=TRUE) seriation/README.md0000644000176200001440000003353514610032223013530 0ustar liggesusers # R package seriation - Infrastructure for Ordering Objects Using Seriation [![CRAN version](http://www.r-pkg.org/badges/version/seriation)](https://CRAN.R-project.org/package=seriation) [![stream r-universe status](https://mhahsler.r-universe.dev/badges/seriation)](https://mhahsler.r-universe.dev/seriation) [![CRAN RStudio mirror downloads](http://cranlogs.r-pkg.org/badges/seriation)](https://CRAN.R-project.org/package=seriation) ## Introduction Seriation arranges a set of objects into a linear order given available data with the goal of revealing structural information. This package provides the infrastructure for ordering objects with an implementation of many [seriation](https://en.wikipedia.org/wiki/Seriation_(archaeology))/[ordination](https://en.wikipedia.org/wiki/Ordination_(statistics)) techniques to reorder data matrices, dissimilarity matrices, correlation matrices, and dendrograms (see below for a complete list). The package provides several visualizations (grid and ggplot2) to reveal structural information, including permuted image plots, reordered heatmaps, Bertin plots, clustering visualizations like dissimilarity plots, and visual assessment of cluster tendency plots (VAT and iVAT). Here are some quick guides and references - [How to reorder heatmaps](https://mhahsler.github.io/seriation/heatmaps.html) - [How to reorder correlation matrices](https://mhahsler.github.io/seriation/correlation_matrix.html) - [How to evaluate clusters using dissimilarity plots](https://mhahsler.github.io/seriation/seriation_cluster_evaluation.html) - [A list with the implemented seriation methods](https://mhahsler.github.io/seriation/seriation_methods.html) - [A list with the implemented seriation criteria](https://mhahsler.github.io/seriation/seriation_criteria.html) - [A visual comparison between seriation methods](https://mhahsler.github.io/seriation/visual_comparison.html) The following R packages use `seriation`: [adepro](https://CRAN.R-project.org/package=adepro), [arulesViz](https://CRAN.R-project.org/package=arulesViz), [baizer](https://CRAN.R-project.org/package=baizer), [ChemoSpec](https://CRAN.R-project.org/package=ChemoSpec), [ClusteredMutations](https://CRAN.R-project.org/package=ClusteredMutations), [corrgram](https://CRAN.R-project.org/package=corrgram), [corrplot](https://CRAN.R-project.org/package=corrplot), [corrr](https://CRAN.R-project.org/package=corrr), [dendextend](https://CRAN.R-project.org/package=dendextend), [DendSer](https://CRAN.R-project.org/package=DendSer), [dendsort](https://CRAN.R-project.org/package=dendsort), [disclapmix](https://CRAN.R-project.org/package=disclapmix), [elaborator](https://CRAN.R-project.org/package=elaborator), [flexclust](https://CRAN.R-project.org/package=flexclust), [ggraph](https://CRAN.R-project.org/package=ggraph), [heatmaply](https://CRAN.R-project.org/package=heatmaply), [MEDseq](https://CRAN.R-project.org/package=MEDseq), [ockc](https://CRAN.R-project.org/package=ockc), [pergola](https://CRAN.R-project.org/package=pergola), [protti](https://CRAN.R-project.org/package=protti), [RMaCzek](https://CRAN.R-project.org/package=RMaCzek), [SFS](https://CRAN.R-project.org/package=SFS), [tidygraph](https://CRAN.R-project.org/package=tidygraph), [treeheatr](https://CRAN.R-project.org/package=treeheatr), [vcdExtra](https://CRAN.R-project.org/package=vcdExtra) To cite package ‘seriation’ in publications use: > Hahsler M, Hornik K, Buchta C (2008). “Getting things in order: An > introduction to the R package seriation.” *Journal of Statistical > Software*, *25*(3), 1-34. ISSN 1548-7660, > . @Article{, title = {Getting things in order: An introduction to the R package seriation}, author = {Michael Hahsler and Kurt Hornik and Christian Buchta}, year = {2008}, journal = {Journal of Statistical Software}, volume = {25}, number = {3}, pages = {1--34}, doi = {10.18637/jss.v025.i03}, month = {March}, issn = {1548-7660}, } ## Installation **Stable CRAN version:** Install from within R with ``` r install.packages("seriation") ``` **Current development version:** Install from [r-universe.](https://mhahsler.r-universe.dev/seriation) ``` r install.packages("seriation", repos = c("https://mhahsler.r-universe.dev". "https://cloud.r-project.org/")) ``` ## Usage The used example dataset contains the joint probability of disagreement between Supreme Court Judges from 1995 to 2002. The goal is to reveal structural information in this data. We load the library, read the data, convert the data to a distance matrix, and then use the default seriation method to reorder the objects. ``` r library(seriation) data("SupremeCourt") d <- as.dist(SupremeCourt) d ``` ## Breyer Ginsburg Kennedy OConnor Rehnquist Scalia Souter Stevens ## Ginsburg 0.120 ## Kennedy 0.250 0.267 ## OConnor 0.209 0.252 0.156 ## Rehnquist 0.299 0.308 0.122 0.162 ## Scalia 0.353 0.370 0.188 0.207 0.143 ## Souter 0.118 0.096 0.248 0.220 0.293 0.338 ## Stevens 0.162 0.145 0.327 0.329 0.402 0.438 0.169 ## Thomas 0.359 0.368 0.177 0.205 0.137 0.066 0.331 0.436 ``` r order <- seriate(d) order ``` ## object of class 'ser_permutation', 'list' ## contains permutation vectors for 1-mode data ## ## vector length seriation method ## 1 9 Spectral Here is the resulting permutation vector. ``` r get_order(order) ``` ## Scalia Thomas Rehnquist Kennedy OConnor Souter Breyer Ginsburg ## 6 9 5 3 4 7 1 2 ## Stevens ## 8 Next, we visualize the original and permuted distance matrix. ``` r pimage(d, main = "Judges (original alphabetical order)") pimage(d, order, main = "Judges (reordered by seriation)") ``` Darker squares around the main diagonal indicate groups of similar objects. After seriation, two groups are visible. We can compare the available seriation criteria. Seriation improves all measures. Note that some measures are merit measures while others represent cost. See the manual page for details. ``` r rbind(alphabetical = criterion(d), seriated = criterion(d, order)) ``` ## 2SUM AR_deviations AR_events BAR Gradient_raw Gradient_weighted ## alphabetical 872 10.304 80 1.8 8 0.54 ## seriated 811 0.064 5 1.1 158 19.76 ## Inertia Lazy_path_length Least_squares LS MDS_stress ME ## alphabetical 267 6.9 967 99 0.62 99 ## seriated 364 4.6 942 86 0.17 101 ## Moore_stress Neumann_stress Path_length RGAR Rho ## alphabetical 7.0 3.9 1.8 0.48 0.028 ## seriated 2.5 1.3 1.1 0.03 0.913 Some seriation methods also return a linear configuration where more similar objects are located closer to each other. ``` r get_config(order) ``` ## Breyer Ginsburg Kennedy OConnor Rehnquist Scalia Souter Stevens ## 0.24 0.28 -0.15 -0.11 -0.27 -0.42 0.21 0.61 ## Thomas ## -0.41 ``` r plot_config(order) ``` We can see a clear divide between the two groups in the configuration. ## Available seriation methods to reorder dissimilarity data Seriation methods for dissimilarity data reorder the set of objects in the data. The methods fall into several groups based on the criteria they try to optimize, constraints (like dendrograms), and the algorithmic approach. ### Dendrogram leaf order These methods create a dendrogram using hierarchical clustering and then derive the seriation order from the leaf order in the dendrogram. Leaf reordering may be applied. - **DendSer** - Dendrogram seriation heuristic to optimize various criteria - **GW** - Hierarchical clustering reordered by the Gruvaeus and Wainer heuristic - **HC** - Hierarchical clustering (single link, avg. link, complete link) - **OLO** - Hierarchical clustering with optimal leaf ordering ### Dimensionality reduction Find a seriation order by reducing the dimensionality to 1 dimension. This is typically done by minimizing a stress measure or the reconstruction error. - **MDS** - classical metric multidimensional scaling - **MDS_angle** - order by the angular order in the 2D MDS projection space split by the larges gap - **isoMDS** - 1D Krusakl’s non-metric multidimensional scaling - **isomap** - 1D isometric feature mapping ordination - **monoMDS** - order along 1D global and local non-metric multidimensional scaling using monotone regression (NMDS) - **metaMDS** - 1D non-metric multidimensional scaling (NMDS) with stable solution from random starts - **Sammon** - Order along the 1D Sammon’s non-linear mapping - **smacof** - 1D MDS using majorization (ratio MDS, interval MDS, ordinal MDS) - **TSNE** - Order along the 1D t-distributed stochastic neighbor embedding (t-SNE) - **UMAP** - Order along the 1D embedding produced by uniform manifold approximation and projection ### Optimization These methods try to optimize a seriation criterion directly, typically using a heuristic approach. - **ARSA** - optimize the linear seriation critreion using simulated annealing - **Branch-and-bound** to minimize the unweighted/weighted column gradient - **GA** - Genetic algorithm with warm start to optimize any seriation criteria - **GSA** - General simulated annealing to optimize any seriation criteria - **SGD** - stochastic gradient descent to find a local optimum given an initial order and a seriation criterion. - **QAP** - Quadratic assignment problem heuristic (optimizes 2-SUM, linear seriation, inertia, banded anti-Robinson form) - **Spectral** seriation to optimize the 2-SUM criterion (unnormalized, normalized) - **TSP** - Traveling salesperson solver to minimize the Hamiltonian path length ### Other Methods - **Identity** permutation - **OPTICS** - Order of ordering points to identify the clustering structure - **R2E** - Rank-two ellipse seriation - **Random** permutation - **Reverse** order - **SPIN** - Sorting points into neighborhoods (neighborhood algorithm, side-to-site algorithm) - **VAT** - Order of the visual assessment of clustering tendency A detailed comparison of the most popular methods is available in the paper [An experimental comparison of seriation methods for one-mode two-way data.](http://dx.doi.org/10.1016/j.ejor.2016.08.066) (read the [preprint](https://michael.hahsler.net/research/paper/EJOR_seriation_2016.pdf)). ## Available seriation methods to reorder data matrices, count tables, and data.frames For matrices, rows and columns are reordered. ### Seriating rows and columns simultaneously Row and column order influence each other. - **BEA** - Bond Energy Algorithm to maximize the measure of effectiveness (ME) - **BEA_TSP** - TSP to optimize the measure of effectiveness - **CA** - calculates a correspondence analysis of a matrix of frequencies (count table) and reorders according to the scores on a correspondence analysis dimension ### Seriating rows and columns separately using dissimilarities - **Heatmap** - reorders rows and columns independently by calculating row/column distances and then applying a seriation method for dissimilarities (see above) ### Seriate rows in a data matrix These methods need access to the data matrix instead of dissimilarities to reorder objects (rows). The same approach can be applied to columns. - **PCA_angle** - order by the angular order in the 2D PCA projection space split by the larges gap - **LLE** reorder along a 1D locally linear embedding - **Means** - reorders using row means - **PCA** - orders along the first principal component - **TSNE** - Order along the 1D t-distributed stochastic neighbor embedding (t-SNE) - **UMAP** - Order along the 1D embedding produced by uniform manifold approximation and projection ### Other methods - **AOE** - order by the angular order of the first two eigenvectors for correlation matrices. - **Identity** permutation - **Random** permutation - **Reverse** order ## References - Michael Hahsler, Kurt Hornik and Christian Buchta, [Getting Things in Order: An Introduction to the R Package seriation,](http://dx.doi.org/10.18637/jss.v025.i03) *Journal of Statistical Software,* 25(3), 2008. DOI: 10.18637/jss.v025.i03 - Michael Hahsler. [An experimental comparison of seriation methods for one-mode two-way data.](http://dx.doi.org/10.1016/j.ejor.2016.08.066) *European Journal of Operational Research,* 257:133-143, 2017. DOI: 10.1016/j.ejor.2016.08.066 (read the [preprint](https://michael.hahsler.net/research/paper/EJOR_seriation_2016.pdf)) - Hahsler, M. and Hornik, K. (2011): [Dissimilarity plots: A visual exploration tool for partitional clustering.](http://dx.doi.org/10.1198/jcgs.2010.09139) *Journal of Computational and Graphical Statistics,* **10**(2):335–354. (read the [preprint](https://michael.hahsler.net/research/paper/dissplot_JCGS2011_preprint.pdf); [code examples](https://mhahsler.github.io/seriation/seriation_cluster_evaluation.html)) - [Reference manual for package seriation.](https://mhahsler.r-universe.dev/seriation/doc/manual.html#seriation-package) seriation/data/0000755000176200001440000000000013056304344013162 5ustar liggesusersseriation/data/Psych24.rda0000644000176200001440000000376512606356654015134 0ustar liggesuserskUXֶhߢ ""J]ZDdJf&>3SkyPq_Q)*nԚ4I$%dښXk)7s;p`9wp鳖ϊD" }1osF'i<|М%~f\>_T;쵙 c~LEl}Mߵq2\uy7I9n?dXnT7ˇo2wٌH>uT>df),}?O)]Y(f ޓf_TsI7^3yT?^Oe;ޓ5j}f<oƏ6`yk<,zZ*[k@_zy鿲΅$Q\ynˤ|.}Y*6 ?I3߼*ve/Z'Ӻ]-w0IYGv+euQ1u{S~sl{9lK'{P&4o?n9|O(OKjwQhóϏc'~ڬoBj5 |Z7> Kq9 2r# m^G3o h([m:6j' 7vǤ΃e"H 7؈y!?Z3PqzXF5.7:z~ns:őy7`KpMyP}vqD švQwT'%'Ct*d0'7%/M|A Z?& u%<?j GhTQ _^i䖻@4)=uu y xc7~L^]p]}DQ':nyDWO<t=!/7vխ [8k<З*_^b'%nvBM΀f_Vs鷿 ~~OKx zB^oxD79߮~/#SAJ_O%u|V|ScWyG?g' xc7~pn #Ki䵏?|!& ^Rwot ~yi G_EFO'%'ݾ'o)pngXAx@KtFx xc83U9qcy? T:ՏM$SkN,zϔfJ: רsel> xЙKf:_S=e/cfBtE&LE[30%6&-8HY+c;9Xg{4IuA{5%HtKwrt.C te\kz#cnzb$fw7Ru }ר7n3־i۵so|;wYbӒ{3ܵ)VlbN~qŕ>7RrCb}mgd׽qb7!edǜsswM~tlЈߵcȃ7bdߵ4s~F6RA#>g]ULFԽmʼni+Y1b-߸Ek񮉎js&0/d]wjxR48lFgoA13[GF̸)Gŋ?or2wEÆ|od*rv^# MH8~>2x=g6Lj_?{m;G[rU+_aZ^zŒ}HGgd w ]wmF]ӧ?k4Ȱ'w1W}cN!|'wmD#2Kϝ~z+cp[0_x嬡Ә|t7s3ˈ^=dݘ1Fmyw;zVw?ip/0<'g8F塛<{6*_5r~I7=*7?v,K;.F%MnwlCnŠKvwoG4~g;m1o<#s^t㌪=c{\ü?wPU6x7epm6>lx.Fh$ZTW^s^{JFrw:˲k z^r-w:]v^hŪyF~8QʽfLO5E4~D..+8kurV^lVj#Q=86߯9H<ǎnF-towK>ryF׬/|Ax>f5+aݐsf/#5`l×5yQkMO/24#둡\hsWZ~?Ώݒᕆl!u(1%:#ܹMqcxvb7ϙaM%]nF~}OFb?ɝQfeꥹ>gFr: ?f{q#k-ǜ[bX_Bl9Ż }ψrĐ]5kzh|u7ӻƽ9Ԉ]ƎDw4#v(7ߓC6*R'd^Zxxpۗܕ.j1K+S|}w0맼#/EQ͍?}ǹz\`L+@<żgcc~2h7ߐ?ԝFٹ]\e*O?t=eʢ \=ϑx=ۯ2BGGgc%5}r ~{ }\L}m[|o˰>>n'jH]zp^a3wO#apIShCSA؅}XC~S9#2.zp|%30pKlŗǍ/|gaC*#&lo42^etY})>;ɨ^^[0df\>Ӄp@r=nޭEOWt3r^yeF.ݹB#߃dG-래|Ó 6ev~H rWwH_ wrFϟ5mSonbD/Β.sF l$&nW|pӶ%ۿ\:!=C^ '2c78t"oEz,߰e1F{޺Swnuo=1p?}#d%b9x/6\=} oYu? mtşS/"ǙzˤwflNZpew <ԋo_:%հ'ßҽv?k [o>SGc?2 k{{8-qf-".H]9ǮFZ_yGC/cFJ/!H^}q0,3g{'?ώ?|F<^+2H-8(W =t,ߴcdw#]|/B:>ަp *܀veFVrOm=+ 캭j{Mk3莬k26Wgi>iK4?| k=bPju[ocN;sg|9ιVpoy~ǥỏ黸cw~S{};ﱤ{w~#6T $#7ҍ?^c[_Yqa_`Y wȷw[51 oO3 ϝ^xѶwKvo9mM.1b[!.{}Cy&HS/?/2\⿚mB+I,v2]L|}//|)qͅӰ {ˇ#Jp@8=g_57\mwҼ 9n;K-GU\H\4  ec5ra=#ǹZT#RA׶L sb"0w5ṗܔs]F|7;*z.S'[[upϭ+Nylq^<{;+"s{"V9%_03w7`NwD~= }#< raU+6vLgd'awᯓOqeIܻus?q{.c+~G>6J7.qrugt| -z6r qNnaC9'SqDw@T  [oȼ͹fMtPН/4/bO2~x,/< ?džp?xD|Z˳4_!-ؽ'}]mKw.xȟLW ;Vg =$>3FrcP)6I1)iǯ߉C9 ? MSܱkU J?v`_NXlξ(Kk:/ (~ ~H'Qnyƴu7ׁ33# /vkoۿiw K^fxƁ kNs+x#gw to>7wV>'!w{+#qLbK_#{@m  {sWڭ﨑!^6BVpNAx|s,Y#xȁ~*^ IҼolr~#?{L`#}M?#98 Js_{/Plf:sTG1 8=Z}y?/lwH'# I^ɳNz5Nɯ\aTg ׶o /8t綮Ά/Ճ8]i9zy4ӟ_%s4Xx&W56su|#5_Xxkc;R,Ѝ_HMGĜs A ? E惜Kyo,{u$YUzY#psr{>mjpT[dcS.tOV s_'w-܇?qF#(r[F W~݉}ikzڪJ yDpp M>Co+[j-c5=^ZyQ׶]{km+z6{}/Kܨ'|n!'D^,cu m/ih#=sh,wr -U ] <H wy~moW?}yⴉ=Qwl v#UAғ t* ңHo޲?yןH(r&~3؛"'|)wS\n7S?q~a8IڻS/*Km_f!>+N#>>?6ՕoUψb%CW|=%7 U9q g݀ޤK|'^g9Og=j{A[奝C&ա3%}{x'd .I+goXtólߚND\ |ה#7mq' rWr`;`J9~.e#nJ]މcy,5/C^Nϐϵf|w޳m Ѵ<U\ FO68ȍ.! ^OVs_IcCpe%Ҧ~N{O~/F;cW8vDl,/Z*W0F*/9>;v=r&[BGoS/.E@l;s|d̛'*:}SEg9~]uO?sK Ϲ>?دy#_L|ssǑv݌^XcN'ݎ?? )}Uᅫ2Is3jUʳ_{։̙觵͔po΁؉R7gsW` _e GW؋ ~~>fo%_Rԋi?? j?X֫_i~(?>6կb#x.ۤ-nrk7Aͼwz!zU=Iҝ 6?G/7]De Or+^L og"WA["#g͜[78{`u?X8o4T6Ÿ ?D?߱B3jS ۂ 幬8#y' ȗX#*NFSOGrw F)uCc`׹}^;3~: CZțYs򓰇x3|)s;+oA\/c'<.a󯋂r˕Gɟ|^]^ھȥmp`XIq8i{~yهPW"ߍ' _\5^w\-]n1e?y ߈Ȝw20m[c^áп)kxE/ѳUrss/R_dI9'zmD'Gky*w`9왣u܃%E_4Av ˅N/N[w'yNܨ|RDß3ZT#}~Kuc75k|nqu+zߓe8ȹ+l!`oۻaoGr_{b5?ǐ7y O!^rlyIUfc݌l|F؉3nTvSr-vTޣz6uHߙ#zmhr\5T]}>~)0:>^S"Õn\Mʗo@39,Է>ެ>ogcЛPyOm^WqNxҼ+ocqGweF?+ȗ~/7:_84-ri eW,?wx1P~=s?xqO[7 MȽ4C?A~ g޹7aZOFn+?M8c.cP~&߈So]g uism|4qMȝ{=ﯩ#8D$+ 'L_TybGE& U_#$ƣN7,~5x' x#\Y?kĮ_ÎxPyg!ժ?m]tpusnLK x?VM|+q B+wu4r3%~3>FsNx}a84RzеG|~33犫2%ϕp~ؓ1~zg̥S c9xg$?9WJW>fk[E_@O{Ǫ>D=6p|펡gm{(yng?c$4/>8~8>E;}y(uǙW:/측ؑdZy4vs ]y4^fS|NhᭇGB-顊b/ܫe;QK^Ih 7n}e'(l8@+ɽ6w'fXoV'|/%_B.r`KJ}8(w#w"5{i$O\r811lqs޷;u}H_>س}GtpN^U.۾rW}޻\sޙMcCG_s97//͇PRu#9CsojL,pap=Q<;s  ~&Qus=܇ՍDme?y]^/􃶨amC[?}L|SÑTу29ڌˌDӕ-R p}!\xmaG #kKG?8p:iڄ i.v }{ּ/ؓ6[Zcr\߼cI#喝-\} ^~jq#2˸ [[_y%ʈ|gG\~Ĕg<8>܃64xm_WyMvn✪f wc5).|/g>{oN?[7MF8Xf{m3K+\h5@#:{XWuADQS:b#I`+6C!Nkb)oZ9U v*2yHvpzP y{xbBgCKڞ'Oi25x6!>𕚃ˉчz ͑_F+ۏ|8?;ύ?7b#rJ}%3  ڶ9 ~_;8۰ )OW/٧|}f#u!r(8)Z5$~tޡ%WUOXO <LC{5ucBUQoBW_D,#k\߳ԏ̚(UYeֱ{کțf¿EǾҼc'IޣY>/GgU8r8v}=5w}C^"?N̍Wz ̞N}PKWG{T|5(o#}\Oܣ{6}B/=GOԼuWA_F~DӛMYޤ~ۑ#A>sSq`s_>s؋(\Ú3!.2^~cZ:ƒo_%">ңObk9m7<PI i Il ^>{7~?l9Jr7)r_Ո_L;eajd E^bh- .u"onC[.zgܜcp+?˷/MR?CNH͇L"~J?.^jFMr[$ Xyz~>uHڅ{w>縪?vȞÇ?:ҹʩ6Ld.ƪOy'˹Oۊ~@nǎd ȯ4߮+>ȋdw{1.Ǿ"ăէB4?9ٿkܓ_(s[s4<{ͽ&^dFsnr {ZQv4wv'Ts53)>Tyz.ަ^#uā>|Ջ2Qk[|OŰKHguwz+@O>+QwN_ZA|~Sh_:Ҫ=^oub5x%v4qGJ!xgŏcq9xBsrv \ykLs/wأ]͊M!2_ʮF O>!>ܶŋہS~G^HΥC}Sl/w&{{n<.˨c{E_|vk8O9;WT;I3?jAJķMC|f@@󐩭Qӱ⟺ɬ%>yփ ~E yܘ;(?ؗeqrn'_,_H^/6qϳѢǚ7 z@9Rt$A\}f6]%[>V>< e֕ܿ) JɿEG&wZ[ moSwýҳ;4[&z`~u2ߗ^ɞeփ|޸揳{T_z=/;1~#}8Vqw˰5+~Uw~NDO0Sd5<9?ꤹ#򜂽<.ĿYw|;x{8 ~<~JFg/ƾJDʉOBNw } GK.FFa䲸W[1go1}m[Hbw}cG|{>ہVpCȆ8#v?}N->xbt_G8-xw~6M ߦu~F`;7Cs[#5v/z4vI)~- >G?Zz|G 'B= 7>a;w_\;7Q{33g?7^V#sԷ2%\z؏'/>.}F"xz%#sirQįt<&;&knyߥߩ9F-^ğwm9= y|b=̛5to> 0Ӧ7 C>ޭdg}j"vc:y};C'.;8/rxF7ᢗc{kcX/gkW?O7$>)>7㜭;7<]}Go97  &U=%~{5׿x>U~=}W[؁ط#&a?ï 7>'*+jܧK'N5/$ǪE'.O}',mѓƗ:ud ,rCɽLaP|0aU=ip9w%dS͆>z. W{/$'v,Vfqe?íax:8psH]-Ct\@<+^qԷ}apGBsm/OU"?^(ǿsc*bAjd6LJ)n_^3v,zwGk8Ҿ (-'*vp<)vX$|Ri#?³O5؅tzkXK<ݐVo 9|B[?7>ϧvuuݦ~ 1ͽ(51MKn q~-WI!z-n[~Τ~VF~5>??W1ؗx+vCv.rǷ{^c`/ ]#~@cWp"|.O4v3')?3zZws8/<,^ңh<[&BޜOv8)[">e׼0}?l,.^S7ù_ͼW9i.X_~l 3}玑]K~%3O:Ob )n ~Juũa[G怓4'}F}(7q:⹿zeZosa''i/E MQߗEej^s= H^=)'ۄv@ى${O/SioXOB>0]⁍GAdvZAy݉S;k6B)q):c3Vū^ .iOxؑ; tpio60`7Oen(.7ͼ:IMޫpPYb%}+</5r.<]}V^Xn@]WgV~ۇ"ς!Яڇ|IW8{~~[3׫/w^tؤyS8DPqe)|sp/4nnş;@?X./$^z_Źgq |0_ªh^|xunw~F=iVJ>/WL =k|2S7ڟa~ͱ~,}~D~ўJTTtRU0fFnEg:7}'Or^ky@|NfjѼR)pu[s7~a%8r=ҳ͜W_y?s; <>37&S4Ű;6z+yGG|,KQ{$>ΥmyʹcG4D^iSI!kk+yk7=Śx}j.e^D)e\jk׼ /U/EaA\<ɜsi_ NDoSG sB/4}9; Rd!v21?3GB^Wro{KsUR ځݢW1ozIsGK'':&=o[} NUdx4/\ =Ѩ5c|J|h":aʫ%UG6)8ͫ^^7=[q%9|:Nӈ;yU[4{5E{=OB˝}6,3G(qW:7дxR.<⹚ԅsM_οgs3=+> ȩzE"su 3ޓ'x '=B(ͿU'x$^UZ _S=1,R}כyO+n[<Oo|B[9/H~k_vY>o4^~cw>x$sO,R<N;jSѻ0YnO7Oj &b\ ]&9U~&4!7髉ﳟƩG[n_n,A\ݯI*4WPqUSk`)}ػO'g;}M۸7<5:?bB?>5xGދ^xQ>2?\M/=Jy&~nzׂSCei*,72\E~*$+OS{_hw,0WE{<.r;͉=%ܩ@~!WcΝ|4_9yoÞxkGDlj:RS%65z[A>ͧS?]F\+e;mGe1r)({}M RɏZPHt%7!gá7\?׆ǹƮOSE}{ěs+r|-}Z(s'g&_Kb\F VxPyů`:kEnC}9?6!ύ.XB/W?!=$9K S ;9oܦrA-C9<@]pg:~?X=oN~hNs3+īq#r Xw湣Je2ҫ~mwlNõ{'ezזG߳6pjbU3l;1k٬> %G}xL qy( އ|\CO#-߉OѺ";4cm_k.zeg<`':SjNr8kF{p/ȟ[Ta<vRد@?vs.o^%З{mgWڥ?e'9{h5g{#?S:U\zیjh091Sp>5񳵝c0F|wpMNׇ(Ll~ .JK'\n9\Tԝ91azU6K]*!sZKx165oWbO>|/O'w#pαH6iF>ax[V?xϤ؁ܳ9v?&>#8D3|8=!\&~Z767w<|Q?QBж / %MYSꧼDNK7zTwײf﷈x;'O'j^e!)Ə>М~a핷~=J])bVlt+zKRԙi6>[kPu&'E{EJV+7kS~^s}5ؗ8"܇xKι$|6>7/B)v5Znz./֦<꛼]j_p%=ᯉ޷K X>8&5p.$>s?F4v)ZÜgDoٯ?Ū?ѽf}gzfMǣ^THwupjux&7Zsk'kķT}PIFZW} o;ʾ!>Lx;ījh Cx2}12[3v{xh/ʿN~v|@B|Rú6᭼sX{>Fo%|x?{F٫x_FtS>^Bw}`KD^⥲x/=L{S` (O8}[.Ee~2 ]4'_>ܻm>A855ȿg9UkėjgyCCأ^͏>+}?o"o{n0Kx2WתsŸ)? R/ͯVu_<(S5z\`weo_H<Y{_4'|wMW%,KrmWڑ\_͹._%$L}fpG(U-9 Ւ㹑Xv =c7hx\O⾧j5ꣵ0ߔN<ꬥ9_/T6/F&H{V/8^㒿Oq?/#<W};z ?f[_vx;sW{|'âyOuOϒNϘͻOh9z4 #2~6h5n?篦 Ki(TG N@/8oijWs>;_xuKs9Ru>K{B|]?amM&+^}=V;43zkW_zD4r_=K[ZS}'= r&&p[!rxn{iR%g<ܭ٦yϹ;A!;ߐR]2JMyUI%q~Ɨeoh?xݥsM ]:mFy-^]L~&_ O8Puŷ0 k{i=w'zTuF}gj\siȽܸBK+?POaƌBs n'p53Ruls\vr(."G2o/sŕ|HyywحR]Uֱ 99.ek_?6]o6;y[c9T4E4yHt־Lu'ϵOOݠ9V| _hɺ*.Ҿ]/9S# ש+NK> š//)BY !a=պߵ|^Y3vr`NSg^Ls=joKJ"ޞC } qm[pnmh y^KLy:Q5ԕޞF;!e?Fnss4r9P[A9_2s3zeKkOϵoqEϵt'\ȟ~בcfx_7\nT|%qڢ7׽9-9cM8^)_s{HWm֋ǶGIS'}@jTO]Qjd Eg]rJ#/ϓyyɝGRd$깑%S⫚eQN|}|穋؉u^S9w5YJEiX/~.KE+4/eF [9;/nm2\m@{?5?7y\#"^3I9|Xŏ_@D !{?7ӟfyGVn*{B|_9DZiʒ8<==ν\K)^}+g˖&"[TiAxvpu硫ǽ uW>{(gLj'4yM7ݥ3jy Cz]y޷X9-؋b`>=,amMnR{ y8(z'8'2x7}2+ky?DbgN?vIg9Y^5+~c~ڔ氛A&w߭f>UuƳyM|OV#]!{|6{Ԭu 6^o4g1x|}Ffr;]&}Ui#ݨ~#~`פzy ½E~[7Qxʭ?V:?Gi%fi߁mZo,>_8{_ojxds!> h>9?_/ ӗɝFͱ;:Ѡ^5%>#x$oYy.q~5rfXԗ>]9fQHJ;  o\J 4¹ti.+w{ۮb3,~W?+ߤk䱻9̿૖_,ϵ&eE~gJ</qd\{;WY=ߍ_‡o?p_G\sψO25FYՇN|-~~.u Ws?hYMwO<_#i0:ݨq5kL}7O|%?_0QV(ٵGoῗ@[~G#&񽡥/ڵ>> mxf??dgb⧀'}r^>Ci[%s3^ Ϸ'_$őqKlUgWqy} j.R`9p8CIڧ'﫹#3G _o q䱳9g&k}^--r~gp ?Ik;y{=)_->1Nſi0@\ߗyŜWb맪|Ń0=##^kMw;9綊OqWzts'7ߩ}mQUk_B)}5y|wӴYKsjYxqv iwb!*ο~ثG3Я~)ް}Uo/wK=*Q_Y6@/\cW"-ӹ晜Gvg7yjK{,q= nkVէr[eK:Ǖ꯿A+{Iœ\*ǿ>tzoeKēz |%>~,FpZsj⚿wmܛo)qsMyo9~+{wO3tFi2A~A8SDϢ'>H=/ P/+>R>z>#e_p.e^w#]{M7#YNl{ {kbc+Ս#859O\yːM':PQ>o9ڮ7$?S_ l_aKq߭wpR_[{Nq4ymt'^z-؁6{>xFWNq؋$Z zk_?O֡xٷ7{#2;$XOխ=nͭJ|Kij'py4rmmI>Nn&VA^8quѶټoHu-ʃ攒?[6m4c}%?Mu8Kpޖ{^źUeRg<{!v®8*x;ݹ7t8C}Ъ=0?/nk_ALGo։/})Y ˪?PR;t_Ѫ~SqQ,WQOMcw Ҟϣ-g+^/ >OhGO^׽ ]x.y7 qs+1=s&y<'K|-qw[iDϒwTs΍. <R'LxO5W3 4Y<=%w3>4ǹHqx⻕IN^W4gq%2_SDGǹo穿xS/KЯj/*jBج5U؝WMGRel//8^ʪcs-Al;ɜY"#x/oT n i`>c|PйO&g!*]Ntˉqi4=N>aG]A:^#O[sacG/x-1z:uxx yY}EK9z;Eoҿ#_ w%1E̿|~\}$#+dBO,vřУRo, /Z/'D}]7Ĵ"w#3{ W7's gӷi/1_v~>F/h.k˜| Eh?w5b^[B/[JWN-?<޼og~6o.2x§vܿooCThvQ?tm//О:bA>oSpQ'=MQkK:yȽfwYW>֘^6M~%i/]E_=O'ۓ{7v?Vyf7hgY gW=jcK/z< SГྲ׿h}ius̟ _XM H{3ZK}udz_>I<4}ߴ>JբKWz:4= ~6]?TvC$z)3 Ws DWov~C%[nnZ$-*oq]|/4kc3d_X*bq9϶ؓQ*Ip1cx*+nY'_9RA85 ;wU '? s.c_ŜkV{~?pg_%w,=r//klsOo"% /9ຣs 1_wߖYUgozϩ{Sp/>#?D$Y ~K,oBmjcQ{aǔ}~ѽ5^8">eϓR!p߬cgҼT$Q_?RlLBHO7iQro N{⵨z~@} âW&]c)p6jP?A|țDž_?0癿J!K~^[>SId=jz7 គ}?u?`oBjDž|E~Gޡ/o7߫~Ukx?Ǯ)}7C5וUu cдi޺Q#g=3m xJ}H"~qM³>#stYSg4yV\f^Z/O.;ȯ[֊Tuڼ_W=e?٦~wtgh^+uK\ӲW11'7s;z#: = fX] +¿;&s/^1G5s,ܫu!(uy!0uww~󲛰-=ԯҟ{S$y2K'eDų3\h \M?K~ +^I-v%7go5,#K Jw7O_hP]%ğg7缅}op :jmgo/y1x} =+G,xgۚҜr?}-83/mQzXJn}/i.>ˉ Ÿ0]U~gE!9n;QbMKƿn_B=eؕDuF]ʖw&^߭Kls'ɏOx|S1ɪ7D6 ^>M|pZ`&{IqMկ&?g7cgO¿ӜGH1_~9ˆI*#ky9v_&rbWSgϥGc~{Bn}~$YG}ܣ>H_uCdT>CmS z5~=|#υ՚WHk>EuOۙO9Okop=^K@^bquk?{襵|Slvx'~'FH{‹3_5 JVo)K5?8H|Skk&.^"S6i?A3;Qm武j1m/ϖWnZ;3y^x3:;ߤ'7ss[U?x]m秊DգWROhmw3{;5܃'ے6졞?U}|cXpU/R}E{ÈKӗċMUF\~ ?l.x~vûLz"ze ?UͫvG-'vEԟQj;MON>䩊nN} ӸFܮ\'WSdz͇Nz%o@Ī}6g4zPsO\?Z!ҫ۰bcs!qy[J/Ok,%=͹}xިKq/Ӱ ܘKOD'?n+oԍ iv-r*Vyua_j0gvyT_οv/vqkٳwc+_D>Ǭ8>t)=ZyW }-v'6_ro%5FG`wKu~%o#~ -~C6amOݧz{Ҽex_A:N pg4؁}i| i;/C|f Y<Ъ<?BL)=ԋ<}j}99>9k' ?@s]䯮~lOIk^y]& sfrr_Gy{ ʟK_9ɥ :lC;s_ϋ !oZ*> ={}xj>N}S4JMu{o9ː'ŷu~m[װ@n(?p5pޡ\mC:>zNO g?+7d#Ps*O]`*E/,^u۶] lO|21ZG&LMD^ڷQ .=kY+Oei/ݓLEp4_͞/G&*ʿZ"RJ'6zヌWrYT{nV)yWaVy}XV-cAKJr9O#+>:oPښ9qdxu9\չ'"7 R+Jwi ?r2 (}[ܜYާ}wB]\L"ޟ:Ӹ'=GDWjP}qj/DJg}/̙TY<}G%WOJ#Zu/GvAxKՋ3gbܯGWjb5chB0siH?iWK!^Q~l+u.հ#N>kSEl.ÞNB_<߼w]"o]89˽" eNªSi8@!=fcopKoW=7]\H֫&VAwdvoY,>u@SNp*lOwv;3GBT<vDDz}sTS<'8of.X>\_)Z*h]x 6=x_R;Rҏ|D;W" 8|{~Pgך۪|gGIn'7-S|#8o h_p'%g&voTc#~8XLvp`jÿZs4L?.i~0kη>H#|:x.<_x016X'{vd^࿉y.FYs?hd\V;W|ԊGߑ&H_Ϸ=|S<; 68o|&6wo:q޳m<;\{YF荧+u+?s]>e?Ky N+'>5j¹oHpwkkr"mG9/5go:.Rd.x~z>]}7b_[o95s !Ӟɸ|1zT/olw]#5IЧ=c~ sY֊9Fy3kM|WIn[ćx a~#^u3=H h42{SO{_oQ@}}]3TWnVW =KI32 ʯ"{_fgwA] 7@}"&Cw_ w ߛX\N9y/Z{*/ENr-'[2qN=뿣9K!1:ig(E8s3~.Z~ZΫB9|6s#¹m:Мo` ƾ0P4k g<_7Lb79`payUxҭop6xd)?x;TrmNڬn46G_*}YOݓ8^қ*>qʇb2y/~x>:NpC*x+/]K &9ηp˦we7nS"<6cCi lp/|ȁ]{mW˛ނ^0waYpuWER5S؅pռe&t϶70E\'= ;Q qf?AΧQ|U؁374 ОY.F.L?/TrU{q-b?Z@"g8zk*pK[zL5^Gjf!'L4/ٗa_aO{D%bGrkPu޻ZO _W3W{rG*0>%O{թΜT4ǹyRin͔чݴ} E / w^rYx!rmO6ϩ +%9 S:*ByO~O rrOGWoELM7x7f}bsC7]A 0|L}o>!rR"zSƞ&'(G=|cJ1PxiLOb:͛^/_p8!}'ss6[ O+𷍦'O [ck-X7κ[y{~vgT>Lv߭}1g6ݴ[e"I\<.[A^"% = ءCc->yO?|o| Ü_OE)>׮}W&+Ջq)zx*skANf.tQߣ Z/~K‘?sxoExoZjA5_C!Ms/ܣi.|W?c5s4h)߀>2SW;P <Syƣ\&pB}5/sl7OmS@}_7 !%QqގDmE25+sS{o5Lo 9kߘGr({9vj_2S%^Cq"mP7ܻDnoA LE}vC#OvY U?:]AaA"ܩ}l7%*5Gߊ|V?4bnCt~E[Ewc:+\C{4G{bp_)8(섫kQ#R?e,yRϬ>*KA]8 ?̃ڂ?4ggbydSw̻M}~?){ϟb8nU~Esit=Z~R7βA d~ñ\{4sPy>95 LfD/ MlQOp;ϭ=jSɯyրk>8~¥zT eG.{[w'L_9u,[s7ߊq$/h 9j;Y>EL T!wMF/?u_8Ϯb蹫+~QW?n[ r9O2I>\[ɟx^O4>W^6<7Q t{];_k+SnpN;A,iS=?Ԣu]op'y=w?<{.C= 2W-أsg7vr~ȯMs8Г9kꨯpczSڂ>/@ɩhd3F?r_Ayo jrW+_)9@y< WB.6JT,/55~}{!*ೠ"ׅ߳<ࡆwV'D^cN@s;xZwjr3ɗUl.1%㌚5ڳj40eV=DD4mQ$:Zyf͡MOŽͮ/ 9nԹW F@_Wz/;{q!ɚDZH칕xJyj#~k\O@u 标 ڳݪVwG77ŃBzYKgcB6ܛϣԥmQ IT^9ϑi܏uW0wk׀mx~ūykp 3^s: ,K<G9n,m~Q=Nk˲1uCUەw/x*7?aߌ+n݅~}ڧ|.~9Tͼk)~ޭ G4T6Q{!޷_OB? w“iOrxmp<#xF4{؏B~Cck.A/CK浐77}Bngo 'nG olפj4!WO7ullDOK_6>K>d}d}+g*g{./b+T9%$?U} vt[jdnA< &`E߉s@gi|-CnwϲWsO7\nP}=|Odpxf+gkυ9=Y驊'oCfO/yM\l _? zT`:n r4:exz?rz[r ymٿ`.87p~!7W[riܗωy;?OI~>ԾYr*RٻV=3}s9 =VB̚+Ѿ}PӅw7gG(B%~9S>)̿+P95'aa//' =p(Ҟ$JIsÜkxzey9sGqyX2;:7ΛN_G!n*GgО]wLopM?!%=\<_cGο ǹר| Pxǚ& v)O,i|pE^XQyP/RquL>ci{E]\6 8T@";.S}~׬}>xԳG~7k5 3)snQR~esyQ#݌_sX0IgL_ͷyw]/ hUڤ<]/,(ϵ?iUvhUi5x/쎵88ټW>bPj͜N<0(Ά*c{`s. yh7;6}qL<5?DSzۄ3=D~ì.εUVڏ(W=WN5yz;B~`ꂡy8ö٪+'MGsY}T'RtN%uĪ9ߦ)Msy%TA??!W؇|PtEW=3Lp[UO} i*|7=x?k\Q|W1U9_ʧ9 (oqesThoEaЬp^_,;wY?^Ryp^usL9/e7>{v P'ZnUʟxiU|h$uEV2A-A%ރxHy__IOΨL{h.4<{Wy ?%^w?⍘'hYbcgDcho/V_n#?Bgdz9pNO<.>9G OY/2?SușuV z\95:Dp#,ߵs}X}{ޠ^V@%9_5=ΖܭamC}s#nv>E*XO QwF&]y$n|Gpkɉ"UUԇ[;6u%kx5J?RBgpz@X~wgEOCڠ8eFIߞмQ[Ŝ%ߒ+zL}HoJs0Vtr纑9 ~;Px_W}[]qHX5جC~}aQ>[ףo=59縋7uӼCQ|U?%s8GmqWaou1uºr~LlS~Ez⎚ pq|Ey K> e]?iUfRP(?_S沛hO77OJ8hWOnxj-s"/4 ~cG?h.>P s>GU~n.yӆ7g <|\=^7=E™V4`vƞ<Խ}{l<-RIk^DK s{c(/?MUv.8-y!ڏmX+9bzǎW^]-7W!^NA|p}.TK؏YP̵cX| ԗp?W6+9NjcQ})@?Ps;}{3}Lpnd={cqY#N%?阣:Z=y߄7bog#) . wOclD~\wǮDz>{W~{4u@4g㺈s$Tr'vN}mi#u;S:,>9!im/kQFf#[/ؓ}') xǟĽ4k]y:g񇦇{ h`5,rp|>oƪvziV_Xb7S^W^>v~kJAx M޻P{X^9b'Ϥ5 (oP)x#Qk;,S}ˬy3g-֏j\]Q nƠ?yDspSq^5ףͻV.U{7ɥːOxf`쥊! 5ggEnV=%Zկ>(Мx GV;_vko\k'5rvpփbWܠ9h~ƴiַnܾ8D|7_Nk#st!1W=y5)[eM =LUջ=:o|眀=?[|fBY7`߯Mb7d(_?Iȟ=Jޯ3{]j$'Xݯ~lJ}ۯh;yqZ1~r7W}jsw7(OQ89GV<߮ Ϋ,~~Z[چ@ "Ϸ{]}63ٷ9s/Lu5ؓ!X־|NsoM _j4E)7jqf>@!7K;岫8WWToU]p'j|Wd)y^.vsgW>Uw뮳p>pTds:Ι xJ>ުx~GWwMw(wzp>.}eI=ow2^cSu_g0=WT#g6*2 94ghĤ6\inXTNW? M#s']߆g ߪsW~d^R}W Wa9zRs/r_oQ<X =ZosuUg p:b7#wK4|egN6IϿ),D],zaMwkϱ#ϞwՔĮ;_4i^3J@yᦇΥҼgxh$7 6oC'B[+7gVr.Μ` aY? uX u g_OM5_O.#T|~*vοrK{'q}<ƒ׋9=4%ݔ "C,`aUʼ1lfi٦/c) }> \ypoMcţ[ ^<}ɫT^&NבzY 2(^T˧W{ۃgVuxHB7i?o(εXsNnxÿ|Fpun;>?0!~Q⯲ ~j!Ygf`O 9FW}WsTopmVFOy~չg!~0c&7E =)޻ ]_{Rs ҷқ(D|y;]|ě7x&Us4 ? .9U'*y6 /`KG7Пιr Y׀bwpԯ-^%Y߀g+圫4Lv08;>1<_~-ea zWnT7}`O;$O iS*TNs Gў NM'Y&%ch|B{%^vgY&kإv7vOr]zGF8]x32S{2_uaoNz7Iug3Pyɇ`^ bwCȥ9=SEX% t{8ܾ{^ B34^M.(!~{p\JTՃo'? S_͋ro(Џ๢ժq<,t#7=yoc[t?=jpN^=rQ/U?*SwPG7eOqW:c#,i&^#؀ON׾xo'%܂.p7b>߱%3{C/bwjćмgApIq@X~T]9-/۩{j܉3Iw(n&>LY`;`A<ꛮW?͵ڻ#Um]̻vlFa+3K4|kPM;'M7hRBCw7~ESqK^~䝜r[I56NZI:;T{{ %Or$\؊3LYUpyWv8Ҥ|I[stw?\3ۨTmZZ.s`G"*1,\Rh(?|WYM;Eū87 R}P~|͟ϡ׌rj{_V\\XU\V9`?j8GxI ܫc>aRa Ca'OWaTӷkǮ,Wp "%Bq_v?#Z>"k_?` 7?i6T5q=^y"8j?d~j?H kȹќ]}>1GV1H?ˎ$EʯgΠHrSp>yJ4og985˟=72=.y[g6-oV}Z*T"5[O|.8K_?gGϬg`Zy3wuοK M+/T~6_}' WXN=tRӭgG:Q{=C>r6{gۀndmt9`O#9|\xuv{@ꤦ{;jyˇ/һ>߉s|GZ,-{raw}&sO%OT>cQoiלHxLw?)ԜM>k0_L3J;Uʢh_<ǩ=^gڷQ|W ~P=*kPCϝgR0_ +C4?zjhw ?Cobg*Km]zdRldɢ/}M͑w1{Y<\I>< ͙"9q/q5t%ߛT=i9ḰWElاrk Ƕ'C|QQ#ks,>{aSii5QUYKxbsbJ((\`Y5K͊c?[I]^kP._%ФUŃ0Ouk~Ϸ݅s*OW+_9kL[7-7s-wOkuc>MsOK^WؿۤOUeYMxxSs/}kRTՇ{54gʽvnĹ$h+7[e{\Ow!vҕ4my~wΠ.ufܳy>ۻVG}AvŭO,:/,AS5 ;$^6iNZ{*YaTh9X|өѾ6J횷t&u:*^cyc8hyϮy[ۃګI+qGkX4o|}vݪ7;hbn"7puɲŸ6Mߢ9{_o3x1O^}Vʟ"ݥ1n4]wnǟկ>bV {}^-Ѿ{wxthߋ}+nQ>S5AZWJosvY?sa~ѸͼE,.plWŨ_hQiC SBG*\BqF5Dz@èV?[Vm_uZpdӹg^\u;xdv~b/g6i2u=v%zYzqsն[h/Vkn (OU}j>g;zM'6oqùTgOogr/[T`z!8ӡKki <@0I!kNW<~3*QF{'70ϗ':́iʅ ׬C|7;;T Ju7C:Hs_aϓnTnYJGt4vy=]ڟ}"%U2/!XړدmZ'jpJާ!iR^?׻<$[ أbpz! MIų'>lL>q5y۵yO;T{Ŀݬ9l4Wju[%~6yTZ z'ߋVޤ}/rR_aH%xږ{Ay=ȿW*lQZd~zgQx;5_շAs.sTMZBQ"~ uyC!MTVsRyʷ5g4_l8~Ծr=~0yr#{є?n~Nf'oZw'tx2^Q?"rnާ-OQ$\PjP|sk@lb:[0oq~qLG*F_՗Q9ۦy U} D}51AOJn[\٪}|@v3r#YR}8󸏼Vs,}PhmGMҒ"͇Wx=__v_'QG[_NտYIڿ-|e]^HկJiMī5nůMTڃm_9WdkT۽ی#~l=_U'\D?m%xmiq rR:C}E oQ=*;עBLKӱ;媯TWZċp{9Jɶ9w媯"Og|ƫ B\ؑS{:@LG9Vm8 I J8Zr&.V_ܴݥKVpb͉5O_y;.Ճ_^u/y% >Hdkx-~fmˍ7>[>=33'xzȧw>~bk?_v3g?ޗ"Jy,xʔ=ːs{x6%"ٺ &5Œ^Wiٮv&{.l-Qgǝ k^>54P<⡮Z{[8B}(M]/U)7O1;[݇?SErԏPWb۱>p$D߀ݭ`Hl^7®7}oދj#k"euz2;Ϛo#o]`7}$|.9y6jJ?z=KM՞{kyk?*|Kԗzx2MRh/k{zv_MsּH?/YO߀}q~^q̏+i-POl|*y |glUq^-C BA~1-R}#,pvpc6o9{?_+hV_gk)gSo/봗]ܶ1`\z>x8yq0)ߔ ?%>m}:h&n7.lYzM{xn$_hU_nß]Om6 OQ?S׾53O s%*B/r4PJ/O] qs5+> ?CT<kO}KxѴ_-pge@g4Rs_+gT ]Bdۏ}\5_ {5',j&lGWY|55MT)/ qxbyEIIʱ_ &oR,E;8̚U@N׮97 ;%Odp~ÈkūzR;)>]hTuAأ[TO㜲|ЫOScϲWoة[3j=s,M![o["0ޱh)v`2sJƣ'7ku ~o]͜O SCx؍o6+Yc{;<;#߉ܯ>9mPs.~ ~M<⃮<{s}ö8OvsU+yNfɜo $4.QqQ9l=G>Ϊ+^LK>G?Y?b*_EN˅5cvOL\a Ń?ju\iz-UT-^^ӎ--??5{`م}̵t>} ߾ S_{=r$~̭>[Sλ|wՊUy%OUsYxVi>7IkO}M-a'?c3["B(T^g$,^۵k-(Q+z\9T%HzR1rR"=cMxWѐ| ٦{B\[oA/>ҳ;eK/啱IԸ;7I}k}^xwsʻZD?)OϯV?}cğP?[* +n?% xěm6]O<{4Nmr,|?e->&+J)Zʰk\|ĭ=zM곭5א)g?轏\秪7i/TӅʳ|'>l?)ZVS3v}7]<˰/>issVOkxP1M~fAOֲC~ ;i-+7Gۏn gL䭣.>6Xvdf۫ʓ[/_3m\sO#x-դ؆ݚOo)OZ.Bl;y^kz--uOرNuN+xqGЮyіE;q/u{.6kE{GWf_2步V} /[sW\?cJ>5狇@uz}soO"Qȡw:uv ߤ)z>5r"AR~Ayj_1}b"Ͼ|og1Kڳ{5پs4?ќоc8A49#O}Ҝ)g"yskca'^8[2^;7c4Z2XfO?_O8إ2c qC}ޛ+#RF^k9g!U^.վ&tmvʞ'ѣnͅ^,^„egU~;꣭mz;{,~W>ۭ~(hsl䰬r?7{7wyB͋[>TcrW7Wkv/?T(>(~zy']>Jb~3O(iޫi=[y{wעm&%>)w6űGXs-f5G^ʟcGoV_Cz~٩<:h?{sثglj7O|> g~_+V>|8*^&,\`[R{n; k_cHTWrw+ %ߡ:)%Em{&?'%>J-W~څӯi/u'^\c.ƟYO!.r+ζ*djn">-"9L4Xuv9Ƚ2'k/]y-+ߖnx/#'Xy[⏕iCkg_¹o 5Cwq/ȯxƮX>:sNGc/՗!~S_QM_soYOsl%>;:C{ZK>$s生qWWqz"3|?uFՖW\k,≨67JL"o "Cԏ7SoWUd;?SI0rΙ M+o1m]cۏoC?H#ܻE}FԺ7)Ѿ^p`0K+{Us7xlzsUosNK kY{c‘7w}P^E{}ߠz&o~UvsUwίך_8{}}@xr_܄\;;OO<$J{ P{nxjǀwknLOogY=!<DNG>W7bǛLsI^L#PPwø ?]ආ'vֹ#ĎY#?'޲WsPG`lz O^/5yg|V}wgGnKHvH>w"rT:Dawӡ܎W8'כOᤲmna0fG/Y۹2ʰwS\ _q^틮+Tk븋ä=c #~;|JB'Շ yXNP>q$rcͭ9)Ik^&קxbv̲wWq/#BIߴ:4?U/fyzNsf_r. v/͍ZoMx:dq1yw5炿=r8e7^?޿i6TW?eڿGȁо4g:MI sTU?EYo[5y{gaExKr~R}WЯދAB7[~\W =UCigpϭjE^}\ly{^,|g~q?C8xZӼkmET}l%UoYϻoCJ4H`IL|5K葽"2M_̻C{$-pI?K"9#A6hUmi8R{+FbW;<#gشw6˿;} *u؛+切Jsv~\^C p3۵'e-RW>=TP4Y$Xk zvڻ|1CsySCM_ď>?G|ހ5G]!p˰O r_鹐Ϳ׋EquX9QMWԜm58-۽H#;Ox][I^gR ?\_|E<- sOq%XzYuڲSk_#/%9X2hl^ .-XGުupx0'R8 oRW{=Tϵr+'%h;B} W*o^O&_w\(LjJT/5Q>*qNxM>hmڏ_Ds5W< oTg{xD;/f1'hמӹg[K[~@x g1o/ jH`J*٥>ڛ$vO):Yx.V=0,S9* A9r5|{ս?%eS݋"9v]9ڷxnc-ߤ='>Z#hSE]GM#wxjI65:[yZtikj>sҭ7Ԟ+KصC~xSt rbUw7j/x_ԯ<~V9n>Կ+v7hKx= "?w}awgPi)V2JGs/TşҪsGI{H+U?cGM:>02&>xwvѧfS^;j:ϡsũA?@ wU_Lky[(~wW?RUށnEUgʇG:oqʯV}O4,y܃]6?ɩEY+^_ě#}{Ъf)O!ox C<}NܬegWq_&e|ګWvY=+ڇVrռqėjC..եGfWyק}eIrpeuK=k/9%Wj_7V]\)Ҧ8i&x zR4QS˱6)th>;RUt]ES?T]nUVϱ {gxx)!mނ]jnxFIWq/ԧXOVs+N7;P;oNȵDPGk?O$ᣠ0oߜwI[9GϷgS߽e\BNϞ۰;u{XU'T4z40OiX}Ko}CG/UR{C'O 3G:4| Mud߱Vmhw47`5jNG?Ku9߬=K5>O(ͧ}4犧$l{_?-^^W?o-vMz zwqmMșe;kb/Ӥ>/RmO7 ǕT .v@4VI}ζ5'=Ry|'߀](U_`صQ5kߥXWs;t.xfjA4 TY}Uqi* {ԦfW_bOk5>sF{ſZz,/Opp[O0hR[~XɑMuE# yգsOw{v۟R \vHϱh*(L;Q{1_m繨I8E{S5S{%~}%w{a|ӏL5oyhg|yq߁;42{ǍIkMZ~kv:+38Vq\*Ѿsk]{?^^۰{+kq>c?׀W=sλO ";H$~((mS]U3jOfvI|6?ljWx@_@Lp/OJp#\xfΥ([<8%dd^*iQ,]k~^{+H~ԼeQyoڪ{UsV)Mߕ[?-bEsowjoH8\YYgHGݱ^\=i~/8SMy㑓b)5ޢP򧵪VлO@sVofFzT_rqS!)Wj_)LZ}UW:o~"v[kq*zդJk [HAa2͏L9*Ѽqk|&jOrT{&:WWЂ=h9?Yzspn#;o=h-7u#շ+gu/CXΟM/lxg` F*5|35OtpQʃVk/a /l<=|MTs/i7'VW,ǸϒQL8C Ńا9>_{[UGuh}yg.e6ޫoIT.V^XoMgPru'@:皿5='kmT}/i^8wjzlG/"6T{Z+>/.yJs,n݁}h$^=Wkn^nVEI~y-xx&oi6 UV 'jOc1\,3ЏDSp>^zqvK?%xq=@\"~GJ ʐ{4 zk% @AsŻu(sSoP?h:wnWU`eUcLzpJNU=w5Z"W}vswiORwK]38̭z+xR~feqnxd/sq/zI([^@_•߷jW3٦hN}l/U}u^)_OV𦽗o{`|ooҞOMcgh<{ D.J* )/kRA+C`W МSw6w_? ޿Uq{sǩrK Lq3z2)a_=` C]~ /2!on>U_LnOe߾dޛVioi;yٟ{mS |sNoo} 6.@Oʮ{;r%B{U'NkY՚W}ҢxƱ=Dyĉ5Z:/;{ެzUn9As5ی+sgqlռ[|W^ŭ>tx@^S84gUlV)K^^U?p{w[O}6vFyY골Z'*~ZZ=\^="(_A<#jw y:qIdC?ǹz?%.W}c^]|NcJ ֦x l#o_X{UsmpO5I^؟ۈ3J5y\vJ{6܈s욇mZ(>~~Gp<}N@x/xa:W>;V{?|H,~&bX}9Y)Q_G+T/k^x3м6xSMs$ڳTY{cRpEѹN8.kιA{ [WI0u_GX۷m>zS_F܇bwڿYkKșX> VE}wIżV*7;ܚŃ뼔ר8o];s18 v¢=eK WߴّVq^,)⎂?(8m`ߔS|п})~F>;z:T[_SQr o'5Gy5ߩf?e'$R 6{*RǦlKUSm;^^:Vuű.;vYCJ_U3q̋7OI;9C佳s󈧳}⻶hqkܣ[vȯ n^lZVk޻sA\^_A|`::lpXbR=n2%yˉ뿕VR{Fd +-ӞnέFm4mvk';{~h9!\Te +riV%K|TyK*@ oE }c E|I{\}:y-Qо#}A\4;^!ȭ/|L×vhp!QN5_oVαTu[%h_A~U_K˴tUNȱy?!/ O;]ZUW.?IA_jGOih=ժ=M ѪoghSI|KgϏC_ڣU .6ՊοLaWJ ؛#;'Ds(8]ipM;,W?OS?X|JGJߠT5S)~.R k~Fs3rjGe6*<o2rW>JB{w~v۝=S,[{PYF»2UjTbc7F="kkHs< 7 =oͣy^(RYq.+<--3ϛ({u:YrS:%Y p|&/4*xxćG&rhu߳-; }= =]m|Q?MMh cA;׬H{t*?w/rU=|tF-~d0ʳFo0`k M6[ܯ;?lg<6wI M~ 5[lnl0`H2`xz\Qwq淴)alfC@jby`_͑qU}Dr5Yh _?`wG3qMlyCf>bo Cg~.U[9 [o^މa-.' I'O2=HЉ:P!F3WHb}QmO|;KfOl!Y}rBwlQu]m1+o—uJ4'/v5S_"mS{q41_ث>z4moDO$_N^9''83ȱzpOQ<TYA'RU~ypS}^;yGuCK{z!أTqsj;㽺#a+\?{L!ՇS?,*}ww>ĎO" vě3Z>\dWo 9 ;iǎ>>5fC=G|x=Lx+~>}6ː753 F_y&U)Jl)jQxPsPb3Q'Wx()ȺMOx1}6Ľ7~ fD<_<#7+ogK'o ~~p'şN t# <_k3\b{y#ސI_;n%=}6&>bgM+3˹~.u}!?oKwًR[u\C9}FSK$QONkM}a o/ zx\9=Lw7ϋDLxH9k `c?|q4_o=Kwɟ˾|xB )/L;܇^IR'ki\܆,z#7KG?H|O5;xY{V"0?ݏ~ ^MԹۨץw Cz>~F+2!qq4#_Vp޷gv$%~dpJO+yMcGrމ\{;Jo?k7Rݒҳ{[M?-GY "N5ؕۜg"GJgeG*K3  j~3F(P&,7/ƃGW>qHl& 8hy"{ ߅K.!_[ѧяJpUbRj!ݿn#geOnqmIC=yf+\5W rKorwA"z9IRS':-}/v>s,~A/NA_KwD"oZN1طgOF/S?McoBӅ"(U?pؑ}o ;qP~DyVg-Ρ^s 甙]zS5VAvO g7#Nofo/lGek!ꚳ5( L<}%ZTHen ă~x>={d>TK?#&3^U{oƿ P'o~ZH~4~'cuRW ^/r2~K2_g8ߚŧBQ ѧ.Ntr#c}]_wq#qeG,#1ڱKS #Q#^<F[G}a]b$@0>'q1g#;v1!.^'nC,߹Fi%g@.pY`.qYzx]H9Ll_F!y:g4Ogy5nF칔e\ر9ĕ ,LjO}u?V 𦳔:}Ɗ M= CW]; ټZ:>/p~agKij}}_wn"gPqBj5/qx&#ky|' ʄYn3{YWQIxnQJZ_-&:RDŽռOhYM4E0HR9$؁R'qoQʓXBvVp ȍoع{[K`gv E'ݰ {"#}ywkUx,#)ħ[Wuз`? Rś!G) W31 TovnV \]r.%8L裉㟂>ԁ[S-P>߳y~p}p,5V}{s~"pY_pr?#KHެ:\p1sx@=zܵ:9y?[o_5?R=I|S7oQ~b2v0܁3Z3:?E̻vp=BnBC`4$~Wƴۄ􊿿He7c"U9N<T<>[I{ދMo*_q2U&,*+OuCO!/N{nR 3} x=-?W9s폟M.^#X[pEph?,#~ַg!/wp6 I^֣H=v1qC7R䇫縴= #KyG;O.-y&y&x-{QN8gțR} y?}߉WStE-3b])zs k9᫈''(:y[v!.r; ~t]!gt)0IqFj-h| ǜiҧ*?c~b3mˏOKSR g㷋~2a +$f℆گ | ?~ʯEu 1U䑷MUm'^\6Z?xª4cO~7v<3PyzCEzn@)#q=xũ=kx|dxq;yᎋ}'Q꿀/Q"'1~]ڛE_ƞԊo;u|D`v&8'Bwװ/1ǁ*zHhr]u/x2ASqH{&#)دƒ j#3&?s[ѿ}gaȗY4ߓ{$|北An5,>, `zjX\nݵyC3ne= <3GmOufԡzWj#ٝNT/ |:|:#mX[x- DqC)P8yܟEd]Z,Yz*  9 ; {hl1~6sy6E\+?#mN"^'g!pت|&q'uأV]8Wam.$.ڎ??(sH#E[!ļF.#=?N{l Xu#߮Ov1"E< gObSOc|ob:`gS<9WةMmA^vW?Ȍ= \^;^']"^T5Lx zv!X?D`BK圗]MTI]n} .yyF{5':q0͛"\>[=~8zzCCg9,+/GoJw!'f*:J_E?Z|!=wSy3VpΑyau*>!VF_|pݾ߬AmG'uScU`;ѻ 8+Q]v|߶ŽEC/c5o{6<k9Z4XA?j UV_WL# @]vQIA̚i#U>IDCџxhyh'h>Ca]&ɏ].?eGVc2߈;l%W,Sժ5?V{5;?=C>H~o+N.D;N~i.Wȷyqt.[o>u3^up+]%q1b⨒#.=MNt3`rz.R;JY |e'[\koK?+Uq;^_L[|Np&~ئ|'u&>Gi@.}=ֻ{oZe->;Ew2Gwyesػ|~z x#9KF#}m]M6g5q艿[|ZyP4OZ?og*_F^{ ͨ#pP]=ā-BP?x$< K~/ف>sIǹϕsnaA=u v#iz7# P?ֳ+/9׺Wd/m؇z`p_P3ڪ=⅏Bܕ8"iQa_&ý_CI!q#5 ykBTRߣ$]1+>Yvu97^=>sn?ϿS}d]%Cx GmGk|9 eBcSZv&}_¹c׌ VjBU<~G_o~M#>2g,H!rԢM+^Ck}g9޻ԭi]uH.So<}Vh/&hbg:v=|:qoCt)!J:|23>I>t#n1o=srT 1/IK8𚻉zc[_T͛|_PsU/| 부̚wmneEwc8<_b/nn3x<9:vڧ*/Ψ~;'Q'H<Ɨaϭb'{L~gib9m؍ܕ~AO N {E3 y}%MFʉmSxKC#G$FWBC㦷/r=  `gJē>aoK<^BzlG>SUm7bq .KXMHy55d.[WOy=>2'8//qf.= z3 .d?OȊ#rHMC<ڦx7XDwq޹W\`4$O?2$&zWlP4iJg!tÌM.$?;5y%ǹ<˟GG߸}-W|z.&7vkJ͡ќT%8>a밗|Jtzq\tѯy={yr?"u[mz<~Qlb!3P(M^~p֊x<y)g7ҟg;9ap?<˞=hqQ3rzVk ;u/2aG=a붋M!5b߂G|׎x_5c_|FV.|n@`/DGm[VG:]-9Z8ϋI朻SE (}1`Zp=oNtپe8s~^v6o01ĕ_:+E{UOic>e^NF$I[};oZMާ!)E7tU/&iNGqO?$OQn3r5Ut9 ]k^ox՗8< >Bu^Yx3i?_S`zۻﵾ=%+gV~<)SN./ʹqRoLăŭ=׉yގoktqKT ۣՍi5w'_z`5dDNQa,UjosD+-K|@^2pNQAKېS Voc5ÒQ6.S~W]"˰]~,\Rk^<Ρw6?G\H|o'({zIsxޫų:9 .Džo;J7>M:[wxgs3"pڲ`zxƽ L~q(K=NCcxv2^rx7&~1~1r&}d^%?7WT<{ކVK^:$}_oxNRyfICiKz)BfPh#q512;R,\"᣺wѫ$~#roG2爿T?oO;z1/~/r?_K=I+ ^JK9so[㧂gܻyDG+ {;XuЧ5]W"ǀ7'b>Grs_vJp.#NGk2e]qޑg#~pA{UBq>xyOF>u oZձP\Z'xL+-9Ly:+} x/Hi/ZN W3l|z|`6g<};|kmx^Ad߀i>`ċJ:Ĺ.[|߁[moU?ըHo -'&^-y33^qD =V|+*_dOǟ>I%G}%ӉS2s\/REAyV\KNFrOUk496%j*~.Eϓ/ʬ Iօ|NM.{ ip=S"{E?.į<ٷOb~ }YEΒs缭zǮ>_o(x= 5璙}[4gZ*~=W& )VyY91{-B\:2AѿUOaCs2s8qY=/~G_ >Ś8W=|C|7jfYWROS>C} p^PN  xYe5#K"<œcMJ_TǓWNC.Sú[\z74鿋]˜;;uUMqwsI_~<+.9v0g<)P`_|֍!VZS= }\~y3 ڳ  | ^G U}c[QˁҀ O\K=.ב9F{ VϮ{_ zc~(&sKλ̨xNL.z:POI8G9oR񢧮 yപ ٫)͕{딕ﭷn(pyT?NoG>7E*ǧn\A&u)zUVKo7aʞ+OX>ۈ!pUԭcnΡnɨnW _s[^gh?x;#Bn"qtp7 -Cf2qeXoCk 1^|k@ 8*+y#W<$Q L~maEa_o2hCw-mqr߫9"Y^Qѓ'eH3V}m7J|}ll[ۅ<`Cs{vƎu7a"⣍JrBS17ޱ܏q1~uWH݋}jOK9NaBb 9{eZ-T S2+o/[~⌀5'zcWk?-eVU}~x7g a_=|Vs&ok Rϋ׾ y͡_~M(Zv䦏rQP ^B-V36M7wA-⥚_rлGqo#uG3= h@,~d\&㹿2ôuxxC[ߥ+}TGSY߉B+[gxGvP'/RQ7ux rm_9GOK*C~4{Uܔ}B+hox[#>t+7/{(򷉳R>=#_`u[Bwsn-Uc275L!OkSw \!|[ZOht$qd둪sEۡШ=rٲ;`s?n"OQ88u8gVljd6rQ!up9 \ʃIIG.;?+^U? 9L<[ Fʦ`$*84~`yG<[%3-A(%\dIПڿFJЫ|^Npsr0k":_C8l!gfh 񂖃Wq C|_@7IեxsE/k߫»𷉹wu{n6jnQoVB\eڃu9Jss1}2yZI=FvOW2;~׊9ע'k\}A;aO,s\R0_b7|o*yJpS-9Cb~=PSQwi ޓ_\D=(>Y}n竟^K^/WේW#Ex 4G1o: sM{x/u g[U׎!> ހBy-/i?'966k/)4Lq_"3x+>A8D<1E\n0YxFR{+q}=ީ~۵~xf#[נ7iA@8v#ES6}C}-/܉/i&^0glV!kE *^%Fr7~ed5S5 ?|^nꝎ>.&pަx3rܡ|PNk?|A2|___KV1嗿lǜx32~:8=_x戏l#x+EN#_hܕ9t~eRꗝ\D_@ޣߪ}*x_szƷW:{|9@\u^"ލ-ujcrx#%>߄ˇsSEYw!q2?N}7(?O ET8@HG+?89 =v B|{hI=߇\M}5jA o^%דbivPw[} f#N?ig|Ω#]g&H~+6ՋWq?Ku/ ;>T_g#~-+o.h6x-8;αJcSx]ւgגLUkkr> x?*_mnǎ>,շo.E*h9ۍ^b_ۏoϽ~Lsb;X'=|'‡Lj|#ߩ7=hEڋ0Su9NoI:.^ȴor;+R]TٸKV[\Mإ`*ρ;ߥ$M׿~;ʇjυGuw sփ#?7EWq_({x?׌?茪x r/ӸL;}N}Kqiϒ|^ ڧ-ȓCN<ů`pU+Xh_*UX!C_{&q/}_}4Oz[/˖!IG' =k8\͇'}Pv围/ɪ~$%a|Aaˎ 2=Kە'Xɹ֞"z,nHZb~3waS^c.va5~)iO\'zϋ77q7}V}gr~]_!z\G_w!)` 8?V{?VNӵ!j@>q7{̻YzmL.9Uyo$^ʍSL r9ntv~q_> p{#Θ*37=3~}NIpj.3ӷƜ!iR@|^ֽ]6jT|z_e ö7%%AbQ cR? _~᫸@Y2=GeP~jM8I;>B#,C/=W|9'?{T[IoLW@d}~sω >aHmМz]h7~#?Ek/f֠@$.:FG7FܩϪY9+oM%ך#_ T\›yunr.i{*\8\| w(-%(V}\ϧ>)<ϧ~~|$EȧRͣ<=D3\m#rya9KȗuS֏I$>L<)QY1Whv;s5;Oyk!Y ~Ws6jNjbgs7C99ç]ps])pY瑚?sL$o @~x793y&^tO^?e^ O{}az(2ſXKN^2=,z||YU͜c r?T~([7}a5*w`W1pzķ)COӋ೶xv7r2q[/oɛ_n#gm9%=ꪹu'ݶiZ9$T=إ_WX?Ҿ+Wɔߐn󯑟>IJsgX?"kT(y }im] yXGx;S.o!MN\-÷W}*'̨xzBE'U s*ʽU'u=sNI{75<[EnSz^yImGy,QC͍z[oG?gG糩|ĿX+x&/MiNE||S╾Lghzz7:< _m{jp#v"ZA훋^yxe_7 f>_'d5٨ ?L}!U؇F};G=]A}Qԁ:j)ȷ3JTxw1EUi&ups_"_hίx:լCį~D3qI{wH^7'^y7LE_O⿭گ?{ @=^ܦ'u⽦N'L^u+*oм9Sa'!зS |qqNv'rQ Ϧþ]_Ϡ_Zǧw~v>Gc>'>VXs4=wun~sr v^v|9_ďn? W]/;uxYѫ/s>Qbs#y]u'05rhLviho~(UjΪE> >9gRH q>A5{TM/yF/ќ'Okn(?\ ^ :?3r<禣nAW{Wy8g|NyUܯMq^9aM?"=gֽ&"=Hk|m#Kk>;p M !ع+[rZs=uk>PGGga*G>Y8v*3kLW=KQ Gj$зZ$1 \sL}w߃m5?.>ʠ^<<k *S_Hgy?"Iܖ<y~2 6D\zxn,6ZNao=d6~_O&d|B)y0;m%y:SȊ>4GqrQFa*SݽKs%Ey%|i)OPѠy c+"|~KqS\k\!)Ozm؇*5)S]7Iɏ^8 ͧsFa7Լ!;}+uZ B~j[s^)6cSqt:sULﵾv4y0z?QuQ&ѣ,?9u";q)oD C0!63~,*ؾ03G}/˨sXzQcsJ&+9-9 Ps(V*pv)H+݀֓-{E H+lXw049Yw Zoꍍ\i.zrfsЯV_Ro?@#=C{o^d>5]GTqɸxx*o'{$N2ȹT <_|=C_K1aQmQ龥=Uoݮ8R ??Ce9 "쥗C]-. zإ:/G{o _ّsbw+?r[4ǸGg筝?=|h3^ѳO"ׁaGKZ٥ܻ{>YWwp¡KS WzKBqO~cM%vG"I}]<i?5] __{@5Oa|?)/r_n_ZQf DOྭ&CCK97KvĿ~4v3\*;W?ec\XkYV⃺k< ݂Gm*lD5۽{BETDsszt>Wawz^୔&B˶4ߓR~/=]i;8n?g)?xd<͇3{>p7I}xOg]Rgu޺GOM~ܻ݉JZ>sti-hB}ܗmW!ב yx o&irrZP՛ ϥu;X_~Kk/)+0S';Gh}FOa;D=GZ4!.B\ji7gj%zo{J8f?~>{~j:ʐ= =i'c?8=~'h"I^&D(~)r=$>$JR|r6v"3Px>zCK}zJ œkIz3SǶ8.Qzp9}Mסk榬~Lz`"uߘ%r_C2 G{x-=ڏ8\sT9[Z+}W?|yܗsĞ4Y9'y>׸vaǒrB~%7#']%'hnF7QHh{kQxe{׌ʗLԜ-ƁM#oȗ$G"w=RBKj^)o&gn^bG)mz/ ~IAՁ%2){30ՏA8{< A O+pbfz]{k>Y(j&⼮ꗩHpm­pus>)oL߿; %~H_AgA%30} r.;nV3(sye[<#40ߟP[gpvp>,=i<V?Q}Y}?EC~k$fUI?aǫ-M3w9 {َ_' }m-jDPux1N4{%Ow! r|e&h?taon:'L_I3zpoi&/%WJOj`اziR!w}=H=#}G_ ?I[c/=q"ޠٹCˣx6A%1͵ZE΢? UqI/gKj3TPOo4 gOŸ%g|K?G&S;98ߵLlWQk![Յ\>CyWIF|k)/v(tHj_U̇)iy{ϯ5p{U۱s?3 ΍?Ͽ7'ZoIYT+D/ޛA7y3"~}maL$V? ?~ ?& pߕGmOcU~lsT/n7($N+>gOi<޿Wgҽ}*yy*yŧ~2xШ>Auo  ~+*vqv"!/Zqfxy@v43+U(g^u\G_ ~[A3&/%%xcsz7pw!%7 Y}G:/rQ?s-$~n5=\n!i4C<õ˹V֞ s5C>,t)ߛm'kf(npT;OM?Dsv~pUy2G;y0Rxf旳|'kS/coHZzKf{+T~`pyGڢy܏40P'h'qsDrů4osœ[ډԊmlCR}r3TXI]/uIWl?h#j+ujwvi qwz?Al9ws_mo'%0ub)^T_/cNسSۍO?]&~ۨ w ~G4XJpϑlT:7+[3.K_Ùs8Gour߫}*{h>Wzۿ_yLAIwxMYk.:Aۮ:.?Pw3Ul /{VοY.zAC.b0y2$ۗ蝭; *>>sQr5gq#ϿA]aj/5MEi2Ϧ3PKzRRO<~:'gxip2ڗ#*QvD.?[)oL&kȩbo賨n:GmYveu7n~.#ysvltzᆪOC?ddGG]-b3N~޶@s׳/u9O'Vs[1ȣ})صƻƑ _xSN .͓şo<=4RM;>x;|C%k.E}G,!_7ݪ=㵷&+G>ԟ#7g@Yݨ: ~ҳ 7.Y 8 ]Wd4xiwtrT/kB"sjxXuMRճą݅wZx"NJ\3:l=Uyk_\O"7NOWoޫnpuC=|Jp=|~rYM+HjHW=?a%?ةt+L*':jv2Oy1/&riW$%1IUsj%}{)V}ZO׼J%xrQHn[7O_sv?ӼOڬO|_/Y^,_HΜ-{X}mSCwZyȻϸ{ 3zjps`& xig#_<}G>E6Nةg'coBF.T_e#n܋NE?_OsY7Փ^gƫN/΅X닔w'rԟx6x=vKysZq c#[uص 1NݲN!sgU9e>4%ɶ :R7]])٢P>8'<ݤjOǥW,y>|~uu)HqL91CN;׽C|s? 7,sxdbgic3]|nk?]|Ѯ={ho!1׿x`*~L?RG}~i/xK|IEy臩&kO?_vlP>~!ɞ<} oX{5jmopy*Yo~Md@܉!M_{jo$/E\؊,͑SIUO%wˮcsӑ!~O)'!+ppv4qvp^{g[GwoDIo^cǪO݅> ON_wǻ흈Ls-z53nY+@t/86}Hٙa|otꋦ'H;:ar2qPo  9NZp&őo[ȃO%vs?~>r^y>fU?fRל\G+=L+uc_Xto+x'n2*>\kz}_sF7{nsœPWsO;G?>-Ϋ5_q"rEsl=''Ǒƹ!W]sͯlDjœ&z;Ѱ }3;}?+n?x>~O=~}){MWj"B}@|L a|Eʏo/=8n6?R^򔵪{$z]n'vSw O|oY?&jDWL{QMڋfwN|CCa򠦕c\ѧ[z~4={G\=D &p_`C|* v%DAMt1/swR;%3=ko\0X|}^u8Y-ւ+=߮GL=C#|;Lwr ? G|:]}.&un/W9pGrr"-\" >AaWjϓxBg}i\{äoOVbۧسY,|XSØF]?dwഠ`u }kcgFC^Ws_ak(sѫET-y >Ԝo_LxEzz=HN8:qv{-cT9IU9RϑܘR~8"Ox|'MO0 =|ϷDm|}x#՚6G^>t9hI[Ϲڦ}It4x[|仂qWPoJ]/o^mR׊ߠ3υ1;{Ox}N.֞Crn%0? 2U&T+]ooJ 9xN][Y(_T%| \TLws6b_WKKm/ Bs׾FQ,QLx;2BK϶3;ӯK AOm3_`Rxⷫvv"?T>8S~Kg6hS|3ȷ*8AWQ[S3k՗>=]#3sxU{H߈nV_Er>Aʓk>2?ݯn\<\<=JVշW+zמ؛w|N"ǁRwS"So;hfRRYM6F$}ە-s3ljwr qd%h Gѧs(>LJ|>v>] *ogQI}K{t=yGRoGnλ{o-qjI|/-WC#wItW} Ͽ}MO%η~E]2C+|x4Ն^-RS5o/BN6v W38O1\>[q >Pt#'oWȯFq:M9/z8Ps* }tCY^' gZ_KU/=|Io4ahΣGկoByOA+߮`+N+Ϡ4\_% a&tROTiXh}V"ITxbǂ7"?[&ߊɓ&Rv[*S&>/SB?Oսlw6*o;s/*i_h{9hlGѠ"~R|ĉY~d]_C?/T)_{g{ yEǾ'W?[~UԵor%_oW?,3fx W_V{-`?7/oi/F'8++'G%~"q?~~;/c@T<.{^p1 de1&؉=i#VժE?!eՅ񼁻ks ~>o'=ø> z>ށ+ޤ~4$.Ğ-{ }8dy+  EoLj~=aG>W‡];yƾcȫRͫy9Rgp/so=˰7᧋ޡߨ{0\I*~obtl$;r"%AsS). 97oFl`'ÏeN|J{N^|=Pr=5p噋ݩC?DX7sBl49}2u`;yj:RsuM;x P~&LsO*u(X9ԍ+z !u<8IN{-yc«^3LD]>-Gc?ii+PO?t]wsO)١D/"6W9⏿XǏU>ixυ9[%n *l xjùt`W?=ew]ooNցSC`ggϳ..=VcO_G'2Ak ?w  ެ}_~]L 8Lhr8?"~yd/z]x޷?U9{|y݄OvUIޟ.F_#|׻O1bƞc'b7?2`x@=LFu3LίXx{"N[KaU^3Q,yE%}e764ٳRyu״֠רak*ѿ-U*T9uWk_hX|9zS}8q1sV_y[V, U8quU! e|"C ؓşGu7*^ oU$^]4~Nw +ޥ?UK=u~K皽0 0B W1}5|/璯2sCu;UK=X `RB ҏ?.up4WC2V |;W}}-%\˯ے)1břDZs=G p߹Xw;yUoDn̚g)Ӿsx_*cj@o߰/%ǹC_ T>k[<)4܏]߅},־RyhEq.<lwa~2:A޼CU=vôyUC{Ŧڷϻ؀KG/1ND΍)\:.Mq.[''3_(؍nk*/,վB->w FgS;h o)8_/Gu̧W&l26G{U꣭܀*W1ݺ5gZܼOo-wVflCi:DAe%/:^TN/94wd3<=^dGGIgz7W:GO49e&}_M89p){+2?S/HkejnTg&8нSIK;yBBEZ"nI*߫1>`W'R<'e7(MdY6z iM[A#9n\RV\Z1Y8Azcg6OJEGudOi {_#߄~ٯydoCɾu_ʯ #A/"/$OE+ PauoIփS)KWϸ92u@^I\Tbg!lJH˦J^7WfLQI!ɯ:wxL[{|Ȯt/ r"fR o{%>TVu>KM1{*n ts?A.Y)9$J^x4`#yE?uGQ7 ~{? 9{HXu̇כㄣ";%]A\juQN"p)n'G^4R?pK/*.9BqHJQI=)sKKɎؙqyCvf?\%;Tf'olļC9N=Qu4u1<}irwxkP9I?KzBcWD|Է<OdCu>忿{KE}qA:G2'o,~G3DTrž)OC׌>K/وyI懃R!yO6*OQJ/;`emH?T&9.ZxO}]T|<@zTܚqMsu#7)OOV/{XNyV`qx#ҿ9]Ns4˲eUGMOrǢԻ]K=ݨ9}GETv#iMԙ3Kl(O ^|+9 ]J<>R{Ks?w3$ }-sM/ HRup-l9&=VKUB*[iZz\s\^ݎޯ#iCÒ}ߔfiSf9cě1Sϛwyٿ-2st{3/չ&~V:LzV~8#UESoOw?e#gCW[F\|d<{Vӊw2w]TzsP&T ;4}'MnP}+yٕIQ}-h^m\({F_ HݿLĭJ__mCsG 1\87ݏKW\k>n]\}S}MT\eMfd7s~ͻB$Jޒq&1z]=GǧnĿLzշIHUJNʉ,Y7r0\?Cs}U[,\qaC޲{TwH&ޔuOdBe\CtV?v:h˸ԼO+4N]gNL齏|֜8'"W:gc'+J^}:a͎z$H?xyGt!C' ?G^:Rs޳N!-ۊOw+7=Mrg-KODŁ׹Y~TPrﺟ^^yDġq N[V?,k)v/XsDvMz Mj=WQO0#O%7'^^7Eg$K a:/{#oy'oD,?lG Xz(GTLn+x=}RƓ~ɳ3ӯ* ѐ둚oh&~}O~Z,QGUbN=vW5QGZI@q!Hh}O/%s䴬GupdիcϦȝӥ Ù_TWP/#TCvg!姬~$5'VNX8s>.gD'ktJC}]ϺzidG!ɝ9A05876Ko{R 9y=%B|~E^<ԈwKSJ |P!{"H}ƭك47Oh_y':`}RIeS(;{_jx1g5e^l9#,̗={yax{S9ʩs;eϦLQ[isKbgH}'$7*S\ M{yB瑂:Hjy?80u-;}WOZvOyN?POg*o\]Mߔҿ}ZvҤd]_ƈgެiء3D|祐 ^{ܭ<0Em n/yJǏ.$c͊O{&HC ѿ>lXW (^?9'PW1Outs?ΗbKoC :lK\%W6p9?Eoz?7{cq忉 xo3s&}on>E)Ń_:_87BmW_ m+ ?A.dWz3VAˤo> D.>&(կ;]e[yV$ "v{t߾I&xLLyA:g?}^C?Q37U 9BRQkk!陃Iٶ:Hs^UA-F<h" ĤOlKg`O}{H_K}K U)X"pz'yd#?8!?XF~[yY孺Xj }1~3sCu/so 5G<+xv}so)g|8oɧq/8k]-oik'M`n3Vq|F^W?@x4Iһt?%m]7 zW }~ M1{X}$ekQ sO9} 8\ao͒?2"1%\yGvp󯑿N_5p'"KuǑ3/uE~G]89Ry1uM*3?{&Ke}s&e2oے}3MDOT(5_yS\R&_iMEO?x+^7NXoTaCrQg9m(Jїs8UI+zꉑrٻW\hEUJq_3.}ޭȕTۍzLʭs QL] =pt^Au_5[U ϹArCeka oüg1ٹ' J_}|o{PL_ b%n[~{n#og/}|k02Wn'c/t\OpOz&~=ި8*} x*['UV[IV{TD$ZWH.~xF7`ҧGt-F|}FpAiC F.>pNA+s܁'}yV: '§Tg%􁮖yDϹˎW8ݯg#+}̀Kan>rzn繊Gge_S;ymS"6wT¿6#&Yŭm﫢şdl_K'8@k\4});8>-9M,{N\{op:odMuM)qqGp.TjOH.4ge</hM_"y1}7} x8phwjmLv|d`Hţf-q87ceȎ$~p$?^flUϫސs++Ceb7PG #!_7RGNtUғȉoS|A~:BԦO~SSG6w݇'^jK<` .#%;oR5Ks#~랣<ѵX7Kz^c~jW#~F.3qQZXNJ-陻~խ4<죤8W)}ߟu~_scWv*VQgz)=z//|F{W^iK/&PYs%29i~dܘD7Fw9HO.hyCTw'C^Ϝw`>JqNkнX}|xN7)~rWĿ?'rR_¼T᦬y,3ow ;=zPA?drK~%xyƤ63 osn>C5!>0'\~$E]4C&/0* nD[Fi(g({X>4oT"H~nگ<W>K+K2??wjM̜0=d'.o[fP3@>*J{Nws:4c37T\e:;}3ܷGݟ %>SsGgwe'ӧHOJ+;^0z;s7gɞ0lNxsj|I|tԥR%u{괶\ԵLlV?1qQ9}rML?c5OSY~q|mg̥yяg_lCG;7sInpN|W4Gw\#q3?aۊaFdWM2O\z~| }Yg܏)OQ %?[9>*8/pߏ}ǚt gCgoȹu>#'ލN=O]J\p3 oO?пJ?;H|_fx5N)C?@ߢ oG [ /)l%J^=ě g%/PXI!B80oxwQ;&)x!ɣNgpOQ/|;WԥGC~)}xHA(iޙG܍;?"^$o o#sνnȯğnq]Pم*o_Vȣře'Ussgo< wJns. ^wS|dn'?$ǑԿ4wULS$̕ߊ'^\@| L%bNV -{g}s)O\N)np,Mz٬:eV<?8Uqpղ?qx'C9]+2'`>4r">5CJЎ"9gy TI=/|e}9D SOOθ2+EsJU#{FJkC/J%mܯ­qw3w{K[xfpix,fsKgĜ>}x' FFU=Rv. %|~p/+@k~do\+$[>ٸ+7 I>z]z!}5qci*歎Tޓzy7RM%w_t7a uX>'|Gn>rIӿb~y@4Z1@\LbW]!p ) JJqGZ:'kWW1-!lC6gb{fH5ɗ<{Ap. {Y\$|IϸmOaP+փG`>3AWE<.{No,m ^7Ħ>?oK>cBpFfH>MWc>Tv"(+Q3=D疂%;>cS #q4}_xtRMꛎeב>D%9xS_Stĥ|'|F' ]ډO[ykp-'/aP+9JrolQcOzW]kf0:NSP=!1E.|V98pA+J_a'W*-,&uDZ3y氼oꇟ+=Nd~N/ҷ}Fv!rSMp|3ԹٯB$wG^p= Ȼ 𷅞USB} t{^:O#Q|Xkx/o_qrCz&L?G_zm9J=$|qǒvO/Od^,e.JS>r_C]1J?14JCWSc$N7Q ߊ;S'6MgN;?4TMVW9z p#[[M盁/@of\x)=qx{CL]̡G1PK tx-ϊn=DZ%%Eo8W),eT$Ǻ]IŸӗ W1i򎉗G<~? }:3'z|HխFjJ|ީ{? n?"{+_)w3VڢȐOژύV>큇~8uҩF 6p'#7潎y˟Lq`O׊%on1řS_) ~.Nsu>_&(ߑVR!= ~sғԭE+7ėcnx7J,Kk xO~x;MH_F< Q|_rC>~e?үʎ s&{bG?мFU{ZqTXN?nA?{K?c.栂%cR> ?O%xV=Mk_|ؑKoܩpc\I44tnU{u.N+^X\dq{lQ`ne1(劶=ُ^O?{S+IQyިuϞsTor]osdjïKSۓ'``_qˏ\"?NmR }T 80ikoePPwf (| M_NbTOz~UyC ݣIΒ~%6.{{mL¿`wm&_g=L .xJ:=>RESBgIʧM~1{|a/1;$'35QJ#` 5ɿ5k) ?O/қ2xûZfWWŧ؛8.Ѥ>/m3W,4E||}pisR^KT\ UڊBUc|~B9]7Fr8̋$%tMg W蓅軦w. ? 6LRV|&@Q׏y: ^OF:s@tNxVyT9stae/JHgSKm_.<|%e}/w1D?.|c) )MۛRuڹr=PF8/kWͪ?G(풷:gFm,$coUu${SUsVe8J>R]55M+^NS E_%IB_wM\a)y^t5~_?o?Lu}Ɲ#Umv[vn2L<{07 Vm;̱8˶3W7o/c벍U_+Oyγ. ^Up%G*.LdYޣרg»/{]s&v8%OW1 ;gF%>ͷ)yL-oPzm*g}nt!uxvRS rEne9w빼+^MȜR;yQiV7LZs*/UmeǯuK2Wy1ٓ8["t8%ۮ3O#_2avc+_]s&#,J$}_U~z-+˾x|r \LID5K'o!p /RWb\i`ߎU]Z{Bf// ^KV0=Obis5L|D|_g"E?A俓KV~wWc+N7:RUN»NpW2GDK;<o*O|do$oNy)P@mlK??KW(^ϼ>s q5*׷ FM?7QW1B~s3W| p8cikCya,QV17* ~u3SwʯYf,O}&l>?ʭ#G"J >sA:O=/ U5-~ww솧O(#eRyG[H'S=<߿^󐑤diAPp!R=A' 3|Vq/՗jF1#>`O}J u|}z_x`+r 7?Yr/ү'J$|A?j?{s2OhLT:,; 92gΫfM/u)^w,xY6K5,WO>2ōeSwV1_d^= 栽sǟU4> SS_J:OlDz>kz/vǠ}%T7Pe VK߽EޚkK4`D9DXB*^5<,T/qPi;)CSVç{#wegqϖg`*|YRV_a>ǻKfS-\zu[Z0N귡eU?K~Κ#"-cUyx$p} oH}3ɍgGٓ0v&%5*αO9d$^9#g`~"|у޾YcSI3w0'Z_Bvu ;ʟT0d?8ud੅7~\90P$9=k\wnT>~ʤL9\.*/ue%  ͅ*k/}/0;}o~OJ& ßa;@! 6x!wBɵ P`3FM7 _EK:L>1ъ_?UJϲ+OIs?I_5"OSpęO왪O|ڇyUg$ $E# M9Zُi{Neؿ[f9#&?#myw2?MC~‰<Z~%ű~ؓ2/A6̉EwCnȟ}&y3goC+b!ه? wnx,cxt  *)MekܪKo \V韒{?W(_Jw-~M̍0J_q#3Tv&8拝$E)un#0G3KfOIX|2Q&6/[Vi"mXO 2ߜ? x,SJ'68ؓce28#Pi{f*Eޛ?0>A+A OzI^}o}>4a{0=^TŞg7qV|"a=<0y qWvkg:r<~wO9:nviÖJG.žukR>L T╤MreX|O;9I—".ΐD_<ɣF^ >`dT" cOʼ=k"s-_3^u3qrGi8G>9Em›bL>Oywk\a ĎQ_g.O\襺sѯMnTR hgXSGة*:ٻ[B{iM){IA.fo|~[ݧ~J>eI.ұ{_sq=h~vΝ>}L:eJއ\z?{LgOݧ=<棒;k/e]p4wž-wl|o }ԽFSg"ϋA~őQxĚ+x້+*^l#c/MwQ\D|}4rrY sO>js@;@";Sa%m+S?* ߖY//U>bu<3#~>f^x5cLsƫ$ !z{|WO?$s_\+< }P[>5/nBy:?^{?̱+o51+Xx{P$~Lha⣍#7p O>|)8EI2o囩x0Nݾ:xz>S׻sI M}'CpzpxkR9x,{q!woR<~oI%量 JpC-Kߔ9 @{?A_‹G^GkErcgd_l!1t3GK}̑#)a91_g \{]d,|lap2|I˖x B9?{ݼ^;n OU}cDra~ѐSX ^gۃq\MFk>ـ+I7m7nM&yN:DdڋQ>6I6PgW;؟Z;| '2ǖT=Uk94qŭyu_aEd@ ^ H{兟a^'tf؇#_Vfc}>I͹O<\@oʘۋc փG\=7̓e 溓}7'Unx5E7xkkp{O2 2$sw̅y0O%-E{J~6LfAts }sV|;]~4}b^<0>|Ad[GGeZ + ԰g4rJ\f.$٠%/n0`6RO7 ?:LJצfg$}1kNT9,Y\h .zpxkCZmco4˨K; 'H+`޻Y/ҀP)?XW#]}bYuY#Un}_JkeR_g Uqm$UR/T烛sofK}b9M7sx'၎J]}s![=>Qs?L?UZ^D_/\.fϞM~'{;s[;G,N*\y5tγFxylU W?oZ{#ϼC/E*@`5 ~'o _B}KB\uF ,_M-dOۙ8s_ovءSm]!{cWRę uQYS7]25J?.橭W鏒g]2p'cS'Fn-2(*X|!wX{gv~|r(M>җeӧok։[{艇̷٣,'D==7=}{D{,; ߣmv\W"Ns63L<*>Z{{igN&柒lJ+KG٩Cx^P uUoj-C'm[@+mHB1_t(<ʞ_%_c:.dxDVcq䶂zxE}3w0uumԷ [j=3;Çv4'k/F9Pv' \zF:7t&|f&>K/|n E OmAsrw~_qݻ+;ogRWJO_ *>WX~:vs(3 ny#zwJ"`/=1N=N}$y^_y2t8dW~`Ly]|)I<.Sǟ͔')̅eؿ#>H2o{K]ݛwԗtl#ɯf<ߺs_ɾJ~JVGWJ"5x5c ~{*Wn<JgJO]M(Ӊ!7oox—_]u_l\|<}Jpۓ%7A<]ڱW_nms''sZT #8bG[}^t#޸rEKǜRxMk$ؑDn[>r齪#&O:0nvz%c6B?dG'^8>a\³I?PO޺/}շV^ަ]?6H&oT($śTBmO1nO9/i:{|3c>\{y?*?{6g)1HJ_< Lb=!ۡkwc4.;vR쬠ncHo7mbw|SC|2uIc)x4-^'J|ߵ84x<ݘ: :r(~ܧ $zkE^&xf/9~uxEmJN \}o%y7|ao{7^ )I<+8vSq~CN;#[Ggb/־ .;੼9xp})x3 zVz< ~Yj@9?El샚OlZC'9f̧_wۨ)oC?_A}`N=^RٿZx8$>ggѷΰ$! &4}P;w u%L# Cl<ƜQH 0Kia^2ᯫ=Qg? wدSųXH}WH&ef 1~*SK~lԋ2!xu3 ~^l ){]IqoH㿄Q@73[F~!-W K\*\s滍 Sq2^J]whxߞ?WF՟1jԾʵ?<+^9:Os?{a[ > GaNѹۜ | ^釆O+aN|U~.>G%щMk^~b <$&Ib 8(fIRgп~Ibv\nT#ԿT>5`wx}/\-ʋ<#wc+~O.6a>zի=cŘ0'DZ,OyT}rptlw@O}yg%p OYA:o_77{PvpާbWF֩nsiE_g] Ⱦ&F~3|9@j?@Pmb.=$ wwjwK*쵹G?s:j^_9vϥ\eBQųs(J0e>߱Y'!Cviղ%[-GK&|erry!6`%ٟe5E塞mc'5 9 Y\a~$3볤{_*jZӯKOsSGNe7?OeZ pCNSy ^qOϜayRiڱ;O*N #hO$ߔ~$MwymEߍ1Ggój̸?e#8pc_^ oϜs7-ޙe7+//`?i}e̹Ffc pu<(*9 -gswa8%z |P~0? .O74_0<o87~ oᥞ>Cz &7/0G/Y> ŋ88軖'.g#88xW }\pmw9G^<'LW}*8h?;S)ixuU73)vZٗz|/qpO>j$_%uuwyν~~7}䧌}& '?Fyv֊\ <՚cði+ * ZW5' _`Yyb^ ~!xGxP^]\DN7DZ_f"Ւ(.*T0UQ9Є?eV WTqM:P =}Ust.':JGp.yun'NsΥ|~۷poM暓q~!,>pb(_LŞY{_pb[7y^}x\ou_Kս{pK+ 6?C]MŵnqQN rsCUy`0p^}qk=&s;{ULc^?j5S=wf{I=[q+q%uzNaOz{3WP8<$T//:ޜY MbmE|~+t~Fx+(-S0Z'zkk8v_ۢs.=G]{e76L0װצO]~Sy{R_nWϕ#_大Qk$83ߧ<,FTsgO%)Nwj{O Lsls8QPm!7&Si vPڣ\v9v*p^cckcBk${9):]Э/5/\sܽ=J0$nvk{}IZUϾwj<\0>G>B셵m # a;[%qn+:F^rk^_G:ٛb~ )'^pn=\QN_Ô# >~10_6iKC}%<{' NRxW玱W0A%~V=;I_a?:oǽ+W7;,ە=$ s/e?<}I{r*ެ:vf4 [sK*f>H+s5C{SK×ev]w3ch!pCA _b٤>T6x&~-JW~Gػn?qyQ)(x͒ { '=YwKlO}8 X|D?eyTvf/ƸLqΊ-𖳯qaΠ[ʘW}s.az<\\ꔅ;̧dyM=./~gmmeNR7%4R]rNП_;Gr8:w{g<׷ 񘏽=iA}~$[rlH}O,9+(gc:Yy;|5?aw>+;eHXp>ءo/ѿG{FIQw ߵO1 D_>L%={^ xe*wHoDZf3왉LOKه\#yv1h7 ^Ϝ? {6g1%>4L3`K, \^]f?ŗ !Qp9  ^p'dQ>t~{H7ػTz좛-V! |i5e:tn~/D)8k[> v//3l=y3Pj6QHQYqe׹}"Wϊx'~:} 60od NMsϖ < ^?f%yyAyd'LyGϻk~菍DN648/XJx*2߿^|u\|$5ح2i4gK*?IoP^v7zw׽= n8d]8cʋ%:rw9Ξ/hתMZhwZ/ '?svK:8uڣc?<߳ 棩TO3đNe>8Q/Qbx'<~S7Z!n_̱{L7sNF|YcM?Kg?cG.aKL9|fbM~Z | >;'*?;˟Rj!RV]ޚd_f.'cse+>g=[O&!-=LaW!c݋W#r{wzL?F>슷]lM\ b ܾ 1.K>K[(O_ _tΞzb>M7~0QzJ;]GQ{+FTOoϾwc} #|Ix%N˄"es\œt٫)9gϐ^Z<];usO۟d#ONvþ{E{4ك*2om^/U)|Qă֞${C\e}>6v痲yk#~˫ٯ}2{Po1|1|i#,m5u.3X}Weo<{b9 ` G}ʞJn#I:K瀓Y_e>%sDv_ /w32iuUՍ#9Ȝ}8q=O.?_o|RT>Tm7ͤb/Ca=\6섭\%uK xp>;ЯwҿK'ao짉cRGa,e3VTa(\(<_U+0os._/اܠ%}spYs3!SKѯ(y;8^/UW4;qΙmtxUe,y]B쟊_opy ~WF}R`ǯ[cxKxw+vo=]qee>Oc{Iq_8vR|h=utv^fe"7~ٵB/vE7kÄoךӪ89Mެ۲oeh<}H/up:6"(.>>ڻ=9;[ տMxb ClϿG~! ?ZaOl?T_^sLck6.}ȭbo] K/ԷMc/2d!0,~/Zoie̼/1LUJdNO?k;OiTt#ґЈ0֨]K(ih]vMv4\AC0RA;Z|5F,)ck@Us. g8u/}_=[?f_htHpY$H_+͏eg) έzF=3t.+Pg/:x>\oݡoVNn`)Er9Nۍ;XQ8]FvSCog&umK|-ש]rJ97}fk'ӤWoQ=׽ʍܚe!};_v|z-wKppFta48tj{H;ߩ? CVm!Ιe W_Am^rw^|. pszY)}'[cԎb`ꗌB BqpDڣM,Y i4hn*ثs/-n0K eKOzh2ݘFgawE={Q#oc~OdT?T! ͵nؼ0ZO֏=Eƒst~?+['*>,*\.}%-ϫؾ~KTh_S? 6; ~~`|y_ l<;f[-iGzW/xQq@K>xuX}V5AcZ~׽NAHnYOgygm^ur9Ӻj=O1C?(3'}˝43U5FWrR\zXwb7s ȾؿQcYr]=΋֬+KMζEE<`(FuukqWFD}_M1vXIz3qG9#,9~wUho*yFS{~нd+69nlӞ_hOt݃ߝad\[;з2j(~eO~ge?=XKRgFiFnJ 4gsw`ߗy; %MӤO˜F["q)Xo/l4] ? I:h2ٍ>gٗғ7핇n .n/?O{ܫhպF+̽6.7ڏf~e,ׇѼӂ7sCewkfxx#!d*v{2䲣U{FEJn2/t=/=Zy7=_6'o՟ G[_5s}{x^@ y* _;v.cyjR:GZUFagmy6g|HsKJSRhHY?m ]j{c1}v_{{6*o-=@Ż8O6.=+g=,}(=>n׮*kSRxX疍?׶c K,osDQ~8u=K ʵ~1ƂsWKne|(ik[L~naS[ə+JQCPz@zz7~;*ٿ. ԪN4¬_,So{PPK9YwPrۤ Ho 9Tv/5ږ>:pe;+\ظ~-yJW+=x'oBe8#K|fGv>ZvѦ^zXYj(Jd_9iW1H̫Uh=\yAOnϼþX_?=='+ޮ8N&IomP}oޣy>w9Ŏϥ߯v}ў5ߋI~\l?|P}pH8ު]/"l\d?",%n[ [ٕICƮ(8}Ï?fݦ[ [x!F!xhţ7g9SNY1H%_;QؼYO㞋&֗o6V~VJfpٶNֽt-y ?ohQCPq+n藺AöU|O޻IqWׅrHDM$37I.=o{iv;Y_F}_OXj{/]QݻbF벗mOI)2޺׺Χ'٧ҏH\v2|kWylz4T?au<_:|Å}.?5exYȽ>ݫ817TGuIN@o龊OK[9Η^j^!=dYM$d}.}F/r<{,fٳ*@^˿k9dE Ho쯸'"mSqqˮ VRx[yl1~W7߸/[/y޻0(9KNsɻ |RXp딏e6+*T#wOc}&\wa ͟)ݤ{hi!?n~,.;BuT\]*~+{n *NxBaAkJ݋{7s:jg[ w%=I;i^*}yQq`S8G $ #_s^޸}Uw*#S`ww"qH^{y2W*?ݬ8&痜 ]{)~h9N籂4].>/ %]W);{OUhYy6#}.oR}p^[~Yu drċO \רQ[RM,I̾,w_Ő>[-z|Gc@ɺ:Cu).^7A\B~+sk?_R{ef{G*(mMJn@ 4FKu8ߏ.4JUl!;Y2n?ي/eR_FI?9V%@XQ<-X,[/sh.*/% kEhY ոH¦zahٍ?j7$r޿G⧁}TG~LׯZҢ\CD\kmÀ$(^\lVݫ0Az:HñOH/~ppۧ% T[&YsX:Oty:5W|$yRyJ"Wa5[sWm3F /:eG܉co;Яfՙ沄T~7sRep~*ߴ,}l@ױAo%pooؿ'W6|>{8m15inZߒ]_z7\rF۰A|r\ΧYr: cZKԷS$/&xkAf٧bfuO.^aѿ&{T|QÒVRի)jM]zF|i_zaW-%y^);V*&t>}^fk_EvDzȽZzwO^-{~n/;[_/s%!wTvpK. %_#+Xrue z~=4=+C?ř=v&C04oz?ӮqΣ-M$}g*>^vhrBF\);d7Z~y-џzy{ߗ_9W TQHŹZ~Y\} nт//*^MF#3Kgg{_@.w}Η^z[Gr(˿*y=/D9~ȕڝA"o˾Ø-NV5V2uÉ/>G߲wI6%w~i.?.HaDN|%%VLPiXvPGj;VP:\Vh˯/DT2o1?7׹^~6)Q}zòo1^$9\S\lٴA_9GT}ˢ[zcYr9$FR}ves_X,اX2ծm#t wC?YOy/0^}h$PGTJYxSqһNPhlM;nvsq㏚2K$|:>no(ȿ"\@~/?o/7U@BϙSv83 4}t .x,aL}gW< 7W77¹4?.QY+;QרSr_hyQ~L`|u#ٕWj}+xT?O7f76{eW[g}KΔݩI-k V gвFMQfH PW1Re+m:v_mO*>+tжܩL݃{Gr'ϖ-?5s(eQF/Ja5n{%yH7(IJx3Ae#7c꽃eS!($k:ĨT|~p_{[fzNlM#n6[S۵,Rx*= 竢Z<^fWn6n6ܾr݊MmVRt͑T߮Iˮ zFB'z{p5V珳0$}ō_&+8RC<<|`XR٣ZHzgПQBݡyUce__RnK,O;Tq4HW> ~n¶7g޳xD}Dr ćU:P:YzG| pV Mbg'Bo d=p@%߁_YsկN܎"] _ΪӴϒP^i7f;.lFO*}?3ޤ{L8qn|Gew:F]OӇCTrRGi^ x+u/٫e~Lxk N,Yʅտ/\ΩC]w/oYKäݷUTYѯ!dT=eCsyD/%woߨ!Zz3_Tr8|(;Nvv]DՕ:/QxewzKAʐ`IB9'Iox֫˞?/{EuwX7g7VObd_ivKرy+!+ zW$ o\:7OY.?عida[ 8p޶/$*eO(?J^ H/g\.0OGvywkԅWuPJYjgd,_W$҃BmeX԰JwHIp!w0Rު o'HvWkb{)(fV5Tۊ~cjk Iߺ]/%_Ko{N^嶦ZɞXdMuzqɏf욯+z YzC`[(cV-Gwg-B~S\1Y?=ew ?5T[Z5 U]qwdorЗyWqJis+XF{FԶu^u~eW9[EK Z辳}OX^v N}׾igsF{U_{i+O$CnPo>C&gkxp_T^qI~IԞ{,L=[-B=O?~?[:c=bHVWӱ<}NmfU.l-DT٪ OR㖿/]~[qw#>g[5S-L9%?~ΥΗ=-gT=kf?=aUCvi~'ٹNT*w J_NX.iYeџV?ECKHJ wSo]{!GW1 Vw\ٗJ;:ղׅ#h-u_/% ׺uw뼲<߂v򻫙'$^_NDs-/~?#sy7L6ՁVI'?AZ`Hp^5K_T| RK+T_;o%zZʇ%3Ȯ6I5~.V5Sv<6\dKUϙt[o :{.a)Z[:Fyq:Mzѹ}bj>,T>R|sIg.VXF;_'ޅ^鬹ztPjq;k["7Rv]Kct!reԕZU (yf^ԝuS_U\AOC3>|0%Ϥa;WsjK端t3!:GZ78#_E°ޣ#[vqLJ<$MCeFʎ)K?WP]'?Iݝ)|+=GU*gboeη>ſ;(9O~>ࡲk$o=_|xʽ_ +VpwKu#_wSu7\<&= b>I\bȎwɿs>テQ6gO<Jfuo{VyiC} /-{M#JUGO3@ߎ-ߥPsiUqT KW.tmclKV[Nnp4ͪ_]̦(-~oyf5MiϮMsnSuIoሞ+y/]K'߉a~we_S cdkVKN0y|SYX‘ AƲgde k8ĸ;m+=kUϮ{Ayb^?'wG,L};~uʣfJJXRw6J/Q7[c#o+FSWzPsTu2P=t*].+̞{3ڢ.M]]uZnkHrzztǭ5_#=X+ yxt~+;;xxJ&b%޺4E8]~g/ؔ*6YQW]Z[}yu|.?O\Fb-%|r%HNzR}[qQ8Z `G#92t{( <̭Zv}.U[PFu4'_)۾\5V~s/wHn.NΩ8?[LR{_c)47b=*̖\oO݊;s_ׄ^lhn\vjuǪ.}YqS W4?~gd9^+ONlF:>f޲Gr5oErKA~gkS=8$5^v%ȿjot);d{M?V>=Lz%^ʼnzzU7uk%O n/Y'}?J.Dw¾ {KOoB=5O O]'{{U;sV^w]1?V}xv3/fQAݱDZXI_ZeIj uKxȏoIȮF1GyTΝTNQ8õ4*a%Oܐwѹ=I͹ȼzYr~ھk 0_hkCƏ"ejH}W~;gve>>͓ߠ(+7^8CuZ=6ƃ+!ZK{e/=ZH9w7Hfs3U~+_'{~FU?'z{ -1T5'8e˾@߰^vnK!Y6UKX6F#-12?7Ͼ=jDqJ{FG2E hz,ٓڲQ(8+>F|G H^?+Ļ][r|]|@\Gg`'AU35ov,j5|XٽV}N0i?UߤsKCr.[H'X.XujŗycYʋK"9.9sʓZ|4>m!ZY!mU8q)aI0'pݻ:w݄R~=Z"<^:Gǩ7=똩|87OY'`igũ}[6Na43IQ˯.Vr]~$\~HPWy}U$9߃ص7T͢oRWίو{n+OZ![*FGΣRE\0s 6zvrvyœ?腟%QW-Ydw٩dX)Vv%sL^ŻsǏѽw*'yW w4ue; dz}{͇0yty|P΂ET 8E~g\gz]fNP|ն^}=Q{sn~JpǎWпxUSe{NMuxa#e_gHj}jPr0PZ%ҧ.00s<:e'zK:E,h_zRxJF~쭒K` _/}VW[(x#DțJ| /eT? :rK{R *5SW VЯm?{O0aɿ'>sɀ+vߔȮe#O딏,Y#NqC—IzNF n!+ܨˎkAF\Os {%{8:4:=95;}J.vj3.9J >%'JųuV<9oͩ~b䱟yCQ|Ru+-6 S:A"mON)w9AۏVWⰶgS̋ RR~=ۦZdn'˂vYE_9qpx+ [ՙ>4es%!:#uKsow-~w?0ܩ8Bfp w gXƚ)؊|AMh.InsvيU_emŕF=1|zS)W?P|j|ph w{b@p{Ɏnnq/^ Zb,\^ j0yba7}s/Ãbީi KNR?<%/s:^fxrV.?t==coYUZFᅯ]IjU(\ks/u=,B]>4EdOZׁ4eaz޽OVׅ}F} N@m9k,y~gQ]FipVvo=WFM@qM۵/c, :F\{A1 ғz Dh~3u.sdGYGqb/Cn{..q=ZYyQg>\dW3ʯ.8Gx? "<#suc)rjNv=x9W.\c$C͠N-.u\.XKhDZ,<?7yO/r,p˟S\-ė*]ޥa2K#}:LqUg-fkY^{kU'J7p/p5-B 9CukQ 4'! G,]ni xTJߗu_sp;I{t_äP~0Ǟ|R U׽Q,:K݆dw ٹ_Vg=dzgT٦:gdkwYFc1f4oo\<"6umݪK U Us#Y:BW6xl vU8yzYC;{OٺU NୣN{E}Y`{],̽}̗HI>t^<#իÿ=I~}7՞mO#\ofz!{%Jo;'Ϋ7(=n8Kw9BgG7-xytCW?ԟ-FȎo/({z&ǿx/>t_`{WCS˿QHPg`;\ `܆+4hSe+U*{j7wrV~"yLZqxMq_M]e9:uN/ϩ;$̱$FWN{*{]Kpς;7^D[!޷^M *˷yv=x7AS+?OJ?z?ͭQxikz]GHOߡ<-.ypCxuknE/|٧K7+h=/7O]{"Vnyxr'_{dOV3\Sf2$s;{(r} f7wxG(ς̽.ϟ@}͚8NxuW=2a؛b0]͊zLx1J~[rb,=b&1GH^EWv}@vn<}F%σ_eB,mPgkQ^6p"}d꾑Z%ECgzd'?W]vW޼Pϱcc;Uz[ Oron3[Ir3%W\>91:_(Ww5׼lAaZO ^z1fзK6T٣y§&z/ lg U>O<[<|Ƈ/vՏ^]<= eW37ۧϯ/]v>{q-dZg)N]>ze'w)}_E䥭8Q5-;>>؛{m[):n?<<"Ot>51J_ng2 oY wd>;X8dp/7/\&=;dgzN>_uS뿆81&,><ZǴ}$;~.|pbm$?4Y|(}ߘW.Qdc}]p Y+GSwLC}ςUwۤ%P^t-^{wst}*}yH_A\Ŝn>U%ǃIOns/,_}s1ru$q3,[u-|l`oɊWk!ٟxZ]3~!,_v~Yp^U,{2+t^#,nPTx[VSqj,:??MT|bx]Id<{92#{wFaGWMN;[g'[3e' h~<F CV_N@۩X j:x_22UssK5 ~QvmCs F.`{%= do=|;d7zev|>p^ ғ:!I|)į{>23dwU|Ǽfw/;xTݠ"{; x݂pU˫mojKa>ˡY&^J+NN%n1 [K?+U/soI1`%G;ROOs]5ϭޡKߍ^Q'9`vzx}OT,煂r+[6J?;#9Y/޾SltbSʼCqGb'^>J`M7|~#;3:Gυ_~[Uof_\ԁw7+|ɲ?Ko|,m~Mސ//5aW('[|+y";5]*o]4i𤽕{g'~YT[~ޚK\_šT:Zً Tvnqy3@=aVT5_]sW^Q^.JqsG^_ o@?iKo%G١{WYf20p쯯F|.O}c _DX8Ii?;_MMčSjPh <^Hu֑eT ^dGK>@ҷG}&5򢕻ȿeOVO:l8xK/<`exKϽ췇}~9|߹ |s{30Zͦ[Evd;{꼻+~3F~ҿn\ߥuc-{c϶h⇺k5=yO/ٱz'z/qPD=kϞ)FDC8^f8!uێ{Fwi;-> .B򽥷h}+b'7nI|P|~!,lݛ>yGթGZ?gJrt™␂&k[:L ۔Q#R"vXW[>|e?Kg _}$=O˾،+{]x3?T]:sjuc)+KN,_ ξ9^?v]7vIGu俧Yl/Aߥޘ~^vTv^䷖>`:7/x[߮T"9]0Ytѹ3 [tޱ&-w*.{{[;@ɏ7򂕷=h#'{,ҜWEa__كTiA$}?zxNAog-(i=%WuKw⚁ϲI=w wUeG?sҿFWZxf x./W^֕M[I^ʶ2۾ο̋2V!Y0ֈj'WKW>Lt>}Կ-z,PPvw'{F=U6)Om일W8=G_3s3p>[t[/pgo>caֹ4|ѿ={2m-:NyKw :5/m8M`-Axkx)~U34:˺PxsZxff?Vmֿeg]ͺOIl/_6ӊ^GSn[ \uK% q\'ۣ}mS6NWh;q5ˏ7 CVEwcg=}3Vyygceʜ*ΡKydx#&/=g7:F;L\)y8@_{Sz8k:StwS5O+N|ܢ}ْUFn.2Udn똇XrM|kǪ_a_,|^ycn{ÃhKP" {yE|#ߊ6#9yBqxm9Ou {&~nRZ#y{Kv`o:OWޡxvҳ3MzAocXz#+G?#h[[(&eo#9s߳Ɗ>/$W# Wɪ V͑x3e NR&>>|wK{N`_"ck^8UKNCGK!}${9APo+*8Y~8&{;+=\΢~6UmCf_ ^u0|U~-`_t݃K}h$ŵݿw-\OY~E{Rv>zlVRߠ~ƤK ?}/-fS6 }xD]WUV?C׳x֊ko䇪.~uߛ/۞WU+ZԳY~1UW<|:нaO ,h=7{Sж^ {l, u^k=tl%} Ig ڡ#(,{x]sd/7)/Jnj(ד_i\qV6cp{rY&ag}Y";td}14\~g򖆸S~;y7wW*^{;6?hK0 ~U!]n晏z]yUqNӺGQv,\0I:e k',RT'f-|{f{{+qCm+=Y|G*/*,|\sc獇/av{1 0y7*cƳǕyη{kHYmЧ?Sq\~ |9U*^%!AqkdxUy@yʼnY겹w3|nBh!~i={Gxҿ]m~/?װ _ScSl_% g ty+?b^//ߏ)_ | ~+ա_ ^Vk\R}n %˧oq=/0VG}tewK+eTƾҮ^>_(ܬ=>Q"G|u s@霺!^N7F/FVs9qd4PyԂS?8Z8'gy:zߕMCW..7|R]:Sj_QTdNΝcg)o0 uOكO_۶Nvz{y~sVY8\1OF=?¯י+}H~v@z/]8ghɟ/Iiީ%`GC*+Lc8;>NٲuS=pn 3s^?m&fI\KR='+jR rmhdxr97gӢD/'v*Y U h5>9l>Mx/+kJXWZ?XO2%\gBY%3ίw'|Su*lGkx/]ope?zW{=j4GCK"+_P+#E'#%^"!9s-?jCR-n#F5s)u[ģ#O0ߝhT']< m%T7<쵫znK8c/U ;X#_͒/>GmUYoW]u&氍:)0OȾT>WW;_<Tt-DOIGC|UOOHbh48ģ=C2r8}MM؁my#ꌗs37 l3v) K ɟN N _\k>◐!-Ks85kV/T>_F}Kyznq&{Ueu`l[0OLVob_F~~h b_{^ 񷉶թNgGk@uxad_9WrƎZtkmd+cS_ o j_n⽈C9·O9EI^C^ʗ,>MhnveF6xin)1xD8KowI{p${ތ35kTWv{\iX|q)ȑw՛V鞓ė~7[$xŪ}1'5ꟜJ~|h̩Ugjo:fm _48Fys <,Q78'+)B-XyzWUyvMr?ďC%|Y.$!Fǃ7s ؇?bdzK?ŕ~AAYI6@or5r+o}XS1X-o_F4GUs#x#~kj]=^TVmW{Q<կ ;_=/)NUz_k/>+_Y~L{ k?|ɦzȏn 6>x}4/WtSvA~b% y﵈&^;5θٜ_Fݽf5?~Ί" \D+_0yjo?Jö3ݎߵ^}/z탸 ZY[ ρ}1X.B:'~vee.̦=1?LY {k ܯ5B=J-+ô_gS/K[n,>rc%SkT?Ye@싞5ty{Ty*foFC~3)(zs"acwrZN ?Es:V|DVzlu&IT{ؽ}|cyK^^T۸UrW (r/+c#'˼@m_G.ϪB>E˼۩rY|OxJx9Yj8k,ޡءzEMKܖW$؃XMv5]K^SfwPS_d$>K7xf4=6jL>ؚм&S^3,% ReșP~ !ytNޘ{Yԧ?Zy6:/O="=Į>gX-yg/.~i`x◉, Wu[/cèS?m]{w ȣg)q`k ~,~scٰUjW[݋Grϱ$q'zki߭ay#n&xWh/]x{5ۈ>R\VK v0r[­}()/?=a>2qOxqp.ΆoߣU?ZR v;П<ca?>xDKv k!V.u|AWkI0ޜspB]!l4zf/(|uj_<&뎩}?5ؐEY:m4C$K-~cwNOit.E/m}^d*.r^%ZPx"~.뇪i&|&*޴081 _8`ϑێ/F ?rf [܆g[: }5*o%^Ԝn!>b_mkF6'5'0a@W wխgt]Gh9<\a`#ޣ=v}.wu\|ϫ=x q1F9%>kn*ʽT\у&s_}~Əd8OC{?s3/x o;%{yߐ s=)MR7^ߒ47r+rP6{fkcmJu>>gȗ&pn3;.Q7/J ݁~Vކߊ'&NT]$\;0}e_s5 9+sR٢[]d>h'pT}_'k,lpYա9SAjAf4{߄= ~i_>WSǗBuڇS| 0>\QwWWo:ޣn[9)ɪu~Nx@>!7W ߸“zT ~e%>r;7h7ugs9_GK@nj>>[-bomk/s.n3kE癫c}x5H=tJ|KwtӾzpГȏq.(斟Ͽ2<k/W#;'_UB~ eIJU לW cxF|+|Ǫ%2ك@͐6%IV-c8_xFd?>ŏU傏D<í'u17b{I%,9ɇ$恋#8yxVRjzȏ#|K{cwn&T>m | עIoMڇx~"SiQU?&@KB_ Bo*+ߡh_pu^dByH_nސ{:x\ }8Ǻ+9*8o_p[5;IC?īGG9ϱ oSHF~[O}Wy |2]|F)c.?( ;R?L$o6H1x˕CN QǨynXߣ'څy{]#_d+&x!*x GnzA_[ڏka7[WN|N͛"s2NaZG›4o'?:ѹV{iOj.rS@Qnxʡ,?{k=@Id%*.$Ux;ykX}ȇ9P ]ŗ0RyXq*~5xz8 {5afb0X}ƞռ'Ȼ[9|\EoNSDh9 y P^%vciBR~*!q AILE.cw#Py"^1*KkE{?.ޘxHCx V_V !MO?ySvŨGy5?UDTo.!}{Vc_Rx&ϫ!މVS+G8_6fxQ[?5[%pox{<݂X*P|v6QO⧸%o}TVpa\nW=׮-}7ӌ25{"Rh.AG/[JGSMe}.X ?AbTc";? Tw2b-?Kyf~O1~֨?<9縯.{ MGVnMlGŮ{ʔ9אې 2췭9]6$Zn|rbR)~οŎk%k^Ҩ}EWp/Ys?&d>ݳ:-y9To<?9?cϴcG^ qݧy|~.pJdaW^4sVi>I&Tu#qYvti PA@WK48q.nzXa'~Y } ; f0Ul@sϛhyڧI3ѻGu^r܋>?Q^F&%~[-ZODXx)n@z)163 '6|D5=KTop!U iOpտ؋Ý{K{'pz׾0[:u?T7;"?c*z]%:Mث3epw~(#??z~^NI &!2=:RseW 9zNtƟYOڏy|^P^'v |_tV:uxuW?u3?D+˯~p YwsQ͓Yn6B?>-ߖ'34O<~'*}N7@._cJ˵\/؈/Y-91Bu gx&5J"K\~dvF!~EsM/}5:;q~'ׅ[rww[ ~2T{_#V~=׋W9u;|xEFoIex'uBx-qeQn+n5t~/YslWY+䬾yzMF`-{x\W"?ϖjJd"ԗ[5_!Hoo{+}>}AQ5{Y5#*W|hnag!ΏyϿ|G/JwGq괇[Tpr]8 91# ,d_@u̿GAssu?G*Ow6%8+8(.ytpOSb!(_=;tl>bIYOGO-RC;AGyvL[B꫆[oI?n%|9MS9ToFuJ̅'[ r* TWý1x fE?!g۸G3UGփ-s/(l%OPr?KרDV1Lz4`͕_퉿Z։*;=#uuwuLyx?Oe?e'a\\9"\+ߍg5^ߔ͙=ʳUM=5麱ThnNqB ~n~ .3v";Hbڭ~E+/U{GܹӈSʏŵR{kg31E{$۰?j k۠uׁo=c: ?m ++*Ug,J>N&G'9Žc'2k;n3|oj!mB V?sKtOռ+'Z|P}Bw+]}cW^w>w͍kkZ|ܻJyNn͑:|>@,<]|gWO>Q}k qm {ѷ196z9{:O3yˈˬfZUyG8]~ץgZ >tX 65%^-=sKl se7JSI=&R 1 #3=Uuy˽WAr;=[y[>{=3+@f!m逽WY|9{<PW,[9e23@~g6 `?BLpdQg]EG_c9ԟ8\]x êvNbĩ=lj-Gkĩ!퍯YiHyxU|NXuv(M73){] rT0hDKv^Bt3n,?5>V1O2ynWH\m%e3S_4}̕}|jn ?W/᱈m}=EGwGȻ5]2^ǚAYd,:¿'6&%nަo9+M?۰1̽i?]yh߈U7ps+ggwᾍ|~E~F?&vR)-oǨf]zk?d+pU6}(iJHQL'I\TS߯Nԓ->臚ϟwj{O4~eמ.ğo$ufa Rwn-e~!Uyf##oCScT筽0 樯" U!ލn_l!mQs897`kRTԷJ55e8<;9|ŧؗL])"Q#1y◰iDI!7>'u5_9u}O>Sv_G:%_kΡf$+QLQ#ϩD%P+[qnKrNgv#Sߌ>>[)Fv9ȵ]xg3x&su+O\e$?Ryj^¶ x }H׼Q|GN*zVv%#~_6|t\}vj˫whڇ snS#y􅤐߱/s*okR6vn{տ՜K7k*qrt #bI1U|ݘ>n"P\4]XC<bvgJFn~nī!G9B;p4H9vcE/MڟqtO'U2awK()_&&"%Oy'8s7se%m\v,8?O7DScRJkЫq7^>wL|Ok\+ iwk~T{c/pe8R?%~ʯ='ޜoݣЇX}?A1&6p~ kUw/U?&~rbWM,۴oaZsAwZ/ck }G| ߅\:S$V~N=؋ӗ]es7jIv+?`9.{'X'j@⚺} ?>'w潇w!J&?_|됯y36p5>pAQmKGwųœڞ˝ %8{Ro~WTg}L|S{!oV?@gwhrsu?zX?^E^㳰9;v2~Y NB?c2>]@ =uϬLTGwاz/ioCܫxc摿Aq=5֜%§ꆏsߓ(>Z~ic6HYgǞFSo$yﴔ{giz0yN7EOw "~׃˄b vppLb1#)q ^2pu?|[kh;_M#PJ} = Xq|d7c'<)#q^#됃f{<=K]صC "KtNB7w- {8J[_uZ{L_9JwLo/v5|=Cno%LE6IJ^FR^v?v}˽ei_@uċvD|U_|Y7S UR+qUTE6jO//xWg`>UL7TUxc#Orx/7,+J>PIA} 5w&fp#&0yG~[_՜+BTu`G]3迉'SbwmX59%ʛD5{b߭oWY}/̫ Y8ĿaNO3-!ozzs>Ca ^`@-Y_N~|e6䓫՟/`//8B/ GiO![/y#9ׄpYV>-U|_~I'^}4OL7_N'qښsU3^|Q?G7wē" @iW7Tߧ9r8C|3uw\|[ЗjŝDZΛScjaMG/ʛ}W#9ҿhz =Fw\MY7w7%n1~!P}uwp<#kd%lz>g4NV?piX v=X}RAɎl'MPg-o=Չ_f򆃰fY?x vnJiVa=p/&+ޯ=+h$/êU9Oo,XwAZ#?Y}FNHs*x!ք&\G!(xdi|ÜCNpEp <8vmӛaO*Wpoqz,[ǩ켿ܚZJx}q@9Ws5={=ij/䊤.حJo;yo'_5ʧQ?+"_1|N #փ8uUr;{Vm}E3;l9yLӞ_ WS^{c C;҆IKK]3D˩3 gܻc }I?˱z0?+;1sgyJ3:FynVmU?9c ?ISw܍3:^ϹnSqsm'cCg݅<$|WcskY$<3=DIۈo^Kt[Cmݭ=t.?{ұWk ۫OHV|[Ԃ ~CS~O䛢{OOැ=#{=Z?Y7z*<ux 쏷zQqqFbh-P8)G^Kw4y #0?.^Ae‰OZGݾr5v!>R7|n $es0 +8}8'X| ^<?Ac~Z{8S͵jq@qnUM9D}vOVw<$y)7:R{"~qn)G5]%uIQ͕ފ*io͉'KϠ7 qe䤬B "/׻T/+'/R+-_UW\[įIqdݜnҜI!qա*8G<>?ZN]Gk"zpbXx+xNGb>FO 4)<{`/⩼W>'A} m%ȿψ߭y:@d3v/0ӻرqb;ixsv1T=6CfMIIK_f>|uĞ[NDR:/>8.>]ȡ/rx F<~ S`򎝴{7VۥvP{x(~5Gz);`܌/*^CAYˬ~ې!+3eM\D3ҿ0#jW'ūPؗ^j^fo] .W?O;B}JOeFJRgzh. #fKW *yF6e6?a/X{6Cv^Hk5Fr(N@ZsTyx-ez^rueء_7;<_\W]4@<ֶR?^FhezP%/m ^,ZCG]7s\"c49A_"w.;qGWշGޫĝ%#bӬ{X߷{s#GdRNuO|L݂{ w{M/^AŻQ-[ r=կ ŻWTd=>Mb?zQZ;0py]Fׁ,? U y8bi%i嚓GVR%g諊EIqVȡs3/^sw ~(Q_`e0?_^GltyGe gӜglbV;{8KU|g\o{n#X?[Fnd~u?~]{YXo6[#\u܂OMΦWMd/["UC|VzPsh czOEoEQcF>SD\LV_YwD Q߳Ou8朋7yUi.ƞNuDBUw(W1ej'^^tΟS}ĩ~EGD=]&> [T)_I}ks@y&#r+oi]NzrR.# PdzeyzXeWtMFOOBϢ ly;y6/E,[ _=Y|G{SC._#}ji.Ϻ: Jr)ݱN剫'V~qjnK`1RKѻg!7y3q9?y\Lyfppos#m|~p,6/p?S+"tΩB>=ߧ[_̾Cςg9`>@Ë9gpT;э|La-?^rmJW߸-#'9'Aaw?ˑ>҂s()~ V@nJ/66|sadTP[nJw_ЃP;/WBJp7xO zWڟEp6x#/ؚT|}?,3naM q?*0ềs+, ?Lߋg) \Y;| i_;򐾔ykL?^sȥO,G\-Ӽ!Gzٍy4)_ܗ-K}u7hy{ [sZ ?!Uyq.Fg4o^"^ v?rsT>R<З[=0&-ܯ?\⾼Qp8<9ۍ((">"oJ߭M*;]ua#n<]2g.'o鹑A;iK5/Ic+e[5|bN'wai3k=ysiiN68ϜAfќUmn+>Ͼ}syZS{rx=_V#>u%ו-9Rlf6BhoYH |38w(|T98pLJw柃_"'j4Ws&?8'ruؗ[_ 5!,TJ5 w>\x#{죽ղCuϠ‰ȋaT`wGh-yo *'!R|O9z|vny3|q&~ꇧN \#\w'i08 _GG "<ޣ*;|Nr]9mg ̹ᑞ3FyԭBcg:Ž[IF (V89-c'38J끽8NYVݹȧeƹwO>M}{'kjgw|/[7j[}Z紟G=R`WL_e=gM*,z~t}\?g|'ޒWfxg{iGMv,z{q:xa-YG.߃p O?Ei순:x濌g쉷e Dy {}h*/V>}+8gռY{"W_P!~~ڵI]]!vW-6Nsi{H jna/G 7:wo|j[л PfƯГA[΁߂2=ބ#N}^Iqg"pr9?J}ݗ]6\'yؕQ3zحiofڤ~ W&w}˲5' rrȓ'OrvB5.5;Rsqw һC^o]G9Ǣe Ϛ^G 핏`w/ٜ^IȱSB]WB 9zf?9zo V`i:4bSݨ5-Gb<x9{?u>ok4T8քo?B} $ Y|J?nE džp.Vz)|ǟSSM#*?T=BN*#?S~|#B9o6$ʩzs?as~N1N/ <xTqC~\{|k;_ ^*jpA坜~tD3;cSG^39-eM?;E%h/Wܔ*ꂶg#= | %e:} ߠU߁c{xxEplk#ޥ|Dوx9 s]Nց0sRs{;H!G9<ŋG.9j/ se/C{a7LuȯE{n\oTUn|e>=G)Nh>tךYā*'e"vTuaėa|~t/C >YCN=kTp'gIx!ɷ@uu9Q\ 4#(X;c_ ej.opEpDn6Y|{=;"Vy`K5wTy, (~SMqs' CXeRd}|!'g[!&?y9ZۺH{wu_vyUG.>{7zCuz|E^[(|$e~Sp4ܫ(w \}r p{>xs8~?oi' ڇ |3K9_7wv, qH4n'L(P/^}Q4£3ģ ╶ ῭WPO+!0awWyB{pԫ]+*zh)t+[x sR9W"@|Qݰ\1Y[6ri_#&O(?菡Bx1v12>-/<)8?@%SjaUbFf[F+{i36%Oec|~~"^fG%=u}Ap"7FkF!;mي}P_א߲ w _+oZAGג XGt魯xop Oo{.x"(;c}R?K'؍3Wvqv/!o9 ƎT?P{+ޯR'hZ Ɵd=@H(r ]]4`/ bY9?}KOwZm\c҉/߿㙂8ŜY|uyO߉Ӭ]S#i0i^QA+<'W^(|2v[y.+?R]79]x "$~;- 46[}v=Ozׯ}[[H|=·;[+CrKOif욻_3Vqzsк80s|n'HqI5K dדV,UTHIlў{[ca"?gA86}.Ԝw9ピ^R+Q}uDRU'-W}Xs _5? y9o.;Q}yGkjq@}g-9Kȏ[ x?#&|w+}PK&̪8c﯊NH-vaA\MG5iyK蕷<qg1qo6~T}Z"ex” ڰ~ wk{)}k_@hWX{n?򒎶ȓ'[G-4PTo65?&=*/ys6^K_]CxόwȏDT^^|wCý ;izk.aB!iEK+GfAz9Il8ٓ8_ziiUsn}=XQݦ-z_׈7¯:c^#+wG:[㟳5W2y^B:(̼mmJ]V9C^b9re}ޛFTڢqS{7wi'㮧^CžsUۥ>"Yy_#OR~*έ_84s/ڃg=s[vS>?T?V&έ9]:ۣ;*2W?;ڄ~T?jtS|Q~.EyIȍJєq9z= qi=J<5g՜Sy{|{Cս5W*ƑgEghy!1xoq LF..юzC\ok s揉(.=y଴e7 /罖Ɉh?R?d5|OV!^ߣCp4]J>S>#o~Qqv+aFnyzOtuS`?= ]QTfÑ#^W4^|s.7g,_"! N_Pas~K+N< eW5|j#]Fؚ*^{77sݙtf.U_K3 ,Q-ܫE`?K)W/ xq2܏(~n&_rSyn@F]GN}/F3 I=__gx^;z B0M9?U/oy4w}K/'HWcέ|%+~~О]ñ7GN}A~Q$G}ɻӺ| ;L!'Ӓ,>mG,vvQ; 摟> *T|f'_bR<~.^n5soc}bNAw&ia?kЗ#S* yGLWBZxp|ySqЃ¾+0`gM<-[]ڿV|TyVL;)/v{4|Js%n +/XG^̻h-pqQ>6[!؉߳j~* ~2ȏ!8OX{_&^sgZG߷Ux)==BgS|+*ͮ•WơدЕS^>e|ŵ}spOB/}/Ew}9HdiN+ U0]j>xAn~2`^$fh{y3gV1o3Rg xŸ^xί8.h$DktpjxR;7wg 甮=\;فn$_}58;{Μoh1"^J|G7] 4"/'qXxq_|WjğU8W[Ŵ8ޒ}b?H_3|X$F:ˑsx{72לU2Ga/LqC~DC˞^bgCQl ѦПչ|^~%xT^8Csh;ۊ4$x3R_u3#/n=iϗ$!+8bwbJac}+ ]z/D5\jɽx^מ1xߎxGYSowk^G Od3ǐ8ߕsi?Ph!keQ=`GC'Sfȩ[aY ބe9<_տȹgS\o9^&Qʋ/>8C=?{lnUo[JW}=.Y޳g_s*>x FV5Zև;ɯ1; ~,iT1L67<+}j耟qλLAۨs' ~y#{ZγlqQ3ͳ|nV6T>j٦&)/'DZ+yC*h?~؃2Օ&f}My]gyWx.Ux v`!?W_^zqϳ/gYIe:o#'W®d$dmTSyˮx2c7 kg[#ע>ypĻp ?W:?+4A@ϐ(SyߵwqDH(u-wI[qS8ilVT8!ϽQqg;8pu݁. t.߄?K~%|=c18HA%WwrNsM*c7졹loϙ21;oI y</?J͸w^~ՏyM~=ȕ۠}g}>M˔&;AͷQ~ܴ=Ue ,aOKz!F[UoC{ z/hJ#?s-~޲ԃBofgwA.]ԾᚋiL|_qJcܣ7 .Jޜww3TO=?frOn-W]VgzzXcoCeM+φůa^}ɳs6'\y U>JīmU_y7nOq^i]=ذU}x~W>{{t)/[Ռ yq훨ek*[Uwn_B|FiXs9ic+bKkL6_g͍J ./-}3<+<#[2~G>?CXE$l _>oOdxBc/z|fG*N n.8&W5\޹OpS}7iY>5Ȯ|M 8;o ^TP |fx#*l{z{NڠIMc]"wV% ;7GxŒ:?_\=j~oI!y_K8pZu[г5TE?Ew*"*3*~ܑ.^@Bչ'j5o ~;h]x5"KM1R4;U{G^ǰ;>[!>&K_SJ gp6b^҉g{ >keh?V\9ܧU=D|/+oG{5RboH #7cym|O*G4'^v>&|ZV06yNXIx-{3 .)>?.h|S ބ_;= Vsȷ7;K`Gg+(BӺdx(x0R880T'_38|F?>o|rD{ C5?4h܃[pfg_mEB"S#ZsNq_w |6?q}jpyc;#ZpBpyz;cQ5N~1&%Mn c)C,ګ{ʟ}JGʺ<5X]OZV/$n㾪!OEīZ}Gܧ{7 ԏ9!;R~a i(uĉcy7opb {ρʞ%__4 xn0$?**}$?7=t,4G *wz}#t~| ]Ms2 ;T8>sy9\o} ?ގs&Nh}4_TռCSqtX}*[kcCR}&S}(8'"[}Cnmv #߇e,қ=ߴy'fo\L[i&D)'H߽/^= 7 n">4''Oo~>Q{yoW*]}7#t?x8r9K=9?(g6 >L[:yԭG T5Az~aC?Ó_*5T4?м䪏7W!őc_ޱ_yHcsT5;,މ GU%y{ޯ6J8؋`o W-[栿ykFό%gǮW.D۩9٪N|^=hck3f!e۸?{]-[Ńx?T1*09OpO:a⪁4 Z}|ޏq/ g;R9׊X|`G|x -+҉/ Qˮ⼃os=|C_Gk)pih(oV&4Kĥ|oZ|Z饚=tO ^O"?/kCp\qŋvcx3 ,TagoռI)ӴA|U|O5jhp籏Ne4SݵǑ'A3 ܮiЏ ±3?윧|S)?>Z?#>7l?}$g5W"oA!;Uy ^pVul7#؆1䏳Yy]ɹoG^I>=;^]Y<_ʥhT\;dҜJ@];sGr>NV~<9_>80' c8 S]o>gj=r쟥9{W2Qyxq`C}OiϨRT'j?nhQQN^&B[xA ôv])j=o3^B]);f\Cr |ڃH6`K޻|=[>ج\,2LֶId'm~6V9Q AUܷy ܻT_@K䰡Qz|s |]t^筕O$4N#ZI\jG\݄^V c7*|>lfU 'pqjݝ$ٗ[ WF?ӕ*܃_=۽ȋK1_kT|6cϝrǮ'˸}攠g#wp$4 ~p/މl½{&?|Kv3GN{Θ:4}q7<αx Ca+qYsV.s:Naw72$;m/i'>޶aԧ>uSz;Yĝm3CCLg~q|o"O_u^~Ey3EUbŽ7p^oRL"o/bʿ \KMU~|9-S7Sk/zO~\(]wj0W:Qygm3NރJ݋qͽOT?b32^M"h+(Ku[ Kޯkn+o?+D=n?Tȫ:ʃm xD͔۬*~|g4&y렞mϣT˃K ߝW ]q7W 2Yp.F޳is r܏&/}ySf_&_C<9笾#}q0h4S/33G_tu;Xy}wvl?'o4~!$ ܋gUGs\WLϨyx׊6'{sm e?K:@xg5W>uryUu{oJ}+1~P%}oVQ=?-<=@>ǥk>nQB{g)tA7mWJ!>=&.Y);_ߗ]Lϴ煴oܹ7O G/#M4-3r2ixC~nq`5w(3[|y(4ss?êSHUtA2"[HW4]:F\=Mx*(=2OU WS7y{H|;W:zbۚwlvh0$*T_lI9zA|B>r&ױ^~kgܫ;z[9Bߨ{䧺kQ+VDa暟 ^ S7g qgy3ug)՝>S]Ə9 [5X^zqK {ngv35򧾖`35}xL/{9WӐwa^|PP>n|z?;? TevMb_O>83:)q)^%-R\#!ЙpP|kQs&yA;>^z"0P:_\_ /9$zq~wP|GZsy^miNu|7՟LD{⭲)su::a/? |~r/[X}նŪoh6+,qQHέ%1dMٵI_){U<^5T˪xY:\4ښq8 W&Yqn^~J7`i.}T{/Yj,_[9j=Rdf1yU cȣˬ|ۍKYAgYs8%y̋xUW NO|S{Ɍܫk70]gynIwCܓ1s*^k 9,웷 }᠍KR?yĭ8/.k?NF~WeʗZ[z߉xzBA{\V!o ĉ{iċcayVW2ϗ|rP{GxcyQ<@7g?%:ģT%y{ry?ڳ8F;y'=0_'|?URgLCG-%a mT39ԶſD?8R@sOGywd's!N^!NgU 7C/EP]b5 s/oZ>lRK]#?bEڃKhoL$|Kj;n|p pDVVF|O=Voʿ;R?av_EFC-|>}/Gf˓W/şo'_l~>MKb ^Ƚơy}ؿ:}Si!B7~qoK4gUV?wP\}v&xr׸? 5qV#/.^$^ky8%T_?|x)OF}O};,v1 Bg$e?\}˱I']CP@Į#s6՚zN]V8ԞECg(Hcڨ,pPD z%N%v3CȣzWQP>jlG'fO|svpk]ȗ2hnZPM1W`޷BϢ_U(o2C12'c&a-wz}܇]{L+W!7ћ|pVOة>tF.G{'Qбء+d'/pUs^T#[x+]򽊷Sч#Y=M'MAQѕ,9yyzs!,^k=דW{5j\yOqm- Vj9= i?O{| |صd14B)=ϕ ^ՎW9~Gy/xUɽYOs_w>#]TzHoCWx wo!`<音?ϭ #gyc49 U`_#~ge@-#ks#sVk܆<ӑ;TڂV~ԙ?,nzsx&e\K= VVv!<lGczGH 8ڸI{oOVKEin擴#;Wg3rx2y5=zWwg-+δ?9w4 3Vcؽ9qM$b.Y^Wj<4tʋQjG)#e*y} /#3[S#j o*Wsȗ m&&zk?Q{[7R5Sq~O>-|[x߉' =|(>M.,g?)⢏8l摦nAVK|]5g_uo`=WNI@ԱZy#x`X{<)k)@RӢiv >nZ}'wMKm)vOG|%}rmQ| ~_?XP<{A˺נeher_Ga;>~'_;էߝ '!7e^k}8 Z %in#ge?ΦxʶUz+{{K3w {I+aN8j^='^M:] 5[}xKT/?HsR*o#h{\~ď'}o!~yu8yCߐxKjFi7'=o˚=ȳWPZ? 4S{o^Spݙ .1~g G=*x;P:F{poxG |O0Y{1֛{Df ÆįQRH_9=~D\㛧{pas5ϟ%*JxkH q3U')~EqF(/x47+?473R[_վMbGWO;>M{_exY -oE)3O}\sߖb[!͹wB!G<-h]eK|xn4Ah/yՇZ5Z79#j6y'u `z"pJ@y~>uCDm8f !K"=~J|V%`<ܼBSRzwzd/' ٳ[sU~3|JGMi_J)f3k&(@񽆾$lI'X|~Ѧk^[6_;R8)U%=1DB6+aoQ>ߢ = A;GLY-a5 G/Y}C`i=;? ?V\>&Sa/âX} ގ|O_դT靐K:[h>H`Շ]sĊWMꃷH]xҾjUޝ،~b0Oe^)~>NUޱh3G[U+Ǒ4K3'X|u'>fRA^9: ՐI_5sOZ <}zwrC7gknr9]zsᕃӬy4"}#|L_^esLq87! xegmy$$> OW_(ʳޟcWizOx2v y|ڏ|XRh^5rV^dw܇-Y@IXs%/?8W]+1}-\9ثsO$yŰ?Ѽg@=I犟UqGO?Qi۹<}[.JurgcOKg}~, {=q9sPT_/W|~P|oo}m!.WϤx#kj/~z^Sz_E9!ۭG.6p6KC~ܵ?OGjx˵o*[&>kd IۅkUo}k߳C|&>ιd#8;(ޠTgnqi\i oLu+b'׻O^)^`BA /K;_ۗ/*H$(@bEKQA5/ZOgjLF/Bb^j 5}7gOLV?psNjz-P\UM;}ŝқxOkmKmNq%SGq.^z8:}ʏ(lإk R:kПȧy <3cs+dk^8W?GB|y:Qz {ZE_Tx}g]y}ބxC{s[yVVA v'sLNW OT@<3o'MJk9m4>Mn/R^ ;Mog )k$iӜsCgu_>>q{~-sMMC*5_9dםUϽuɻ}x6&޾ȟ{:h{*0[<3fSg`'}#zα(;#=W8#'O٠^X_.dAwy?7) _Ꝍr>2wc;FqK:X:u1qe }vCܣ'v7z1c rI8ݳ7k^/'̍_.ܓopQ 2H6j޽}i%_sw?_p z|gOSkOyS3/An ȗ}gTg^~uoCٴYsA^F;MApszDsjoR'? O^{d4כx>+Oۨ?wZ~ߑb[%TdKܟ-C=֫^?T=%qc9<9ůUΖ،߬ZQEAF@@Ҿ`>zcў@|(7:xT{* XR=MN9Ɗ3W}wKqūꆗg)ޣB,{Oi&R=ZB5/I]ɳĴ^g;{V-񧾏7p*rLN~+5y=g)~=[_&  {hOƧ۹7>Bt6fMF]_>^wDv"]s#Qȵɫ\絯gч~^{sgp*m%I;v|ޤc\#7.^A(ڗ>l ȩo=)'M{82pXأfL@{}/8 vیܧ=þhe6_=e2~{Z괣x")ܢ=?G\9?O'^:5U<ƚy]{}s rkޜx9:#ԞRg(R>Oy=G7p}`csasse , Si]unS|ڵwnTGe7w4wyȿO?P:^89G:S{y;Gs͇T&18yxeROv$2{,-sQ?}w*sDמq'ytOv4R}x%_ ~}UO(5T?`^.a;:QKu?0LvvrU/ԯLJҴ9Ja2* \_H^}4n<n?m:-ṫw%xRC}UP??KOyl؉~z_2>|r'F7|Od ˿T}D<ݰ( ~_մͿC{oOþ]o_g՝ԿQl~@TI>:i2s0\po!et;S}h~dmn6KKcb`_5e|ųx/4;v>\gOXŃn!ޯ!|Fl>UG;XG׾?\}]{tj%蛪#. 4~J|3.spoYg49q8u^cQHdm -W>u#7:~b-UĝG9swo2-Fq;x=58Lb72s5[I1_lεs\<$G޺^UY} UE\{>LM=?}8o{ !7T'Eg\seOކ%~BOKSIPBROJ-W<,T~v1?>u|/Wit{7K> >w9铯T!,VߴP"w~OxN#OwV.K^jB~F?kVyĿ>??ĩyҗ֮:ܫQWqqJ*ApzC^w־x$-]M~Jq=zzb5 Y396mA/DZHCQ(xh;ji\<Օww !܏⟬s 'B .֞ (ǎBnsΉo;7=c^_]h>=H|0;dj_Mq=p'a6y7My;>c/oE{=[{O C׺':]y7G=D4G"(Rߔ6[Hx\[Q[]_u3M<b}Wr3r j繿F6?\> ězhEoߠijjUOu뚳xѤ:'_k͙ gn^ ߦ9[gNCڟBҵ=`0NUw|o^xٹGqXBaR!ai/u /JȘ2!~Ч״W-?~Pqͫڟ}nT`ĶPw-æ/*x&^˼|S z[*p td!˱|KU|wbI󨟋/aQVڗs@8%{QuѼ.ӹBqmQ~ZYyK߃5q/yN1Jc#Zxko [o-Paw?7y4{7o|cYw܅ 6R_ }}U g;?u/܏&I^I"$.ٷ3>w~,n6}pz] nqܬ?˄T6*O'm+" ꣙(uoHHϋu{k{x7okuڇ2KR}S{Ż)>-Yp;aLo*{ TsM+vpqrEgWKC+kB}.-o6ȗR{Hvcqexz΋bwg4]BL;zdXJ[ěm"7]UK 'o Ǜy×ԟq yhɎ=z_{?A{mږWfV&3~to'Ωdia YsVʣ8~?Ļe fr/qۻQ{W³xOS[ף<{q^{ h?w<^m^ސL*58ϗ4/.X(Շ$k>;.\]ǹd\ ~ _W;in297ܕ.>5WXzhN{Nh ;^:$x:Er2n^˧kBx> Z{G )[b.uiOu0#?G5Q;~Q 3_{sS9ϊU<X<0|NhOPInSwj^Rc)xs ¿FZk~/2./5m\_- OH^4+Ƚgv _{Chm&qwQ_E<$WL@{asC.,чʯW:_ \c-wp#hyk#Vk<~{8 \>˚TO??פ>Yσ% .>7ڟ"~ݬV}p`/^~5+ 5>ͽ|mx#S_+O^x<-M~.|]%^v⯂=57p#L<ȖKNp͢}Gw@\yb5ISiqS{^ϸ+_׋_]g1#oiă̊G%ǰB]WU=wx?/gGzwXiS]>j!&!i?+{@c9#~Vsaw xQWcFyg1F` D7ؕQī1=|;rBu{}!)i i#zgkerlQ%G5p sZ<>SQ7k).??|I{e?W]Z?$uu_Ћy^)kՇzV7K?K3 {lM/ګfEZ+쏙7c'ֳԹ ڛ<+oxJ ;L{8íwOy! CL}KaǬ}+n;v>]<:i7}P<OqަU3WpO3mA/+8ϩ Hl&?ޣ pgP}ȅJO6gjGq}yTjGy4[)Osp|~dxПE]Żd?·O&g+U~Sǧ{~ Nܔ>)4VQӧP#v8g(FaaVqxҌڏ>q`7=,JeN掂g8(QӰTi~JϺ~OY# }s|\ȫ๪M+yWoxL24p{=SMCu`yTphS6_݈G} ٭M2F̟&?3rѾǕ3^"nvS<*7{tL<_Ps};B}/7Kq}E~}.Tj~Oޠ6Mөo"Ks)+[u'dU#DIqm1/"{WߝU.Rs|#ͳS`?ד|;Yy$, h^&ȗq*gePIAUi7^u*#ju2 _K{n D2;jVvۋ)c>xͺ|XpvXyxN) y:H߭c->}JF?38)܂:+kz!ٯ['О5G~'oQ:jC})cS:Ne'įQD|;d%ٗ9r'1U>گ` x?92їPmw]ބ#>~x?W,f)ZهbNj?\o=4/z 擮_t=}ڮAC9o } /\inW>]Լ$/uxlȥ/>Ϭ}tgnOs=spw7rsW-絯vu,|}s"GcܰϰQ@?Op_3ړagjQ<P})y\dz<}rn5}%pzD %9o>xƓ61t |{,vv 캱~;.ӾOoӽB.*\Siۈ6l/NlH|0XsG,K{Nkopk씧sw)'\r%p/~>\Y%])=5i~o[s[|ཏshƼV4dP',Gmhi0>.7JyNY\}i~w)pT? S|P9i=9dg>>Sdީ0ثtՑ5^+v7{>}*5| nnU<}7dR}\}8?{?ŅG~#ę9.:Lp^yP]Ny qS4}INuć?5'ywo_&=ަxr ~z4􆄟W?Fs47.> ڊq9 ~<{]nV޲CW׀,ڧ<\<iзġTCOx;2jEӎ&'M[7sS2y2ǝkݢ1ϑÞ! ҊOʺ=@.ԏ>%*UoAk)ySG0z]< {r 82g=ckyW=yPk*Ja͓⽭hoiqg35jߋR=VBC u{þ9tMirv{}){yGW||%K®w,\}"_h߭攼)}8DܯoU:sU$|\r捤/NyFnC[qΨmgۮyn>"SgOI͕9vx/S߈ųˆ=WiwCWi@fCL+3#%c'\wE΍>GO-l 8WA~#=ɣه`sy~ėۯƎن4R<ڷڛ,RK<5?v~y@cپ<;9):O??%,Hmfى\5L[NLFR!;l{g!ӱOx\iY瀫'|i)w}qES(W|UI;Xi{Y& eY XЅMvU_J6(Bror w ɧzvj9x6c7ϛWikhğKprdK>5O8J ,CN /Q17V-[q|xO8px#k^`wk=~V^W4[!U򆰏_.{P;xȑ{i~^몟ɳ=,o)էuyGU0E-'Rz(Z(h)iӾ{Ϲs$d'! 4(;)d%B(qݿz빮:&B@-_nⰲOy\gE/Ы.UW?C ڿ 9*R?cv96GGk(ܯH&< 1:޽ͼF<؎ g=qc)jfy }|1?a@{CwcA ;[Ch+ȇu# +'FjN"7`J$ }y <5=bCVbk.4/;{}:UD{˜OsX@~bl0ٿWd&x }'CӜpr=Ok+O+? y<~do%p1k.:+zmWpd_ܗk~ #?Pt=_&~y?B_Rˮ~/Ğ@Du3ֈԯ Ӟ}'_O>O5K_^[U+ZJ^8'ȹT_W}px}ľ_ͱ2sO_u%оȗy3>?`>K6g ,ϕ_*?y䏽ICtY.ʓ\'/Ρ~s>D^#Ts%ԓ<`Hux]/{aZ媷[?}V;•S>?} PuAK.ٕ{ao&5ۆʼ¢2пN$ǵOԇݎiv~J5ҫHCk 0x(o8#ܗ .Ӡy<hj~&V]5AlY;.]J}-5 >ʬʷtsOQv-?ۊ[wB<$!O]i_‰C T"2ϲL\(}lGz\S2N&|c/Vc{R2_sz%.2pox3Kz{E}4?[Mg^6}J'4Sysk.`[{,/ZuMܐu89D-\ U=<7rNU#_s&G i}_|N]u4S~VOk_̼ik_.*\.]A^O+ׅR 2(Q ]/⣴ħ1Xfvۦ>ƨJ r#~ͣq+#u|#"Iwm5o8[_+>էUR<~;[yʯW|m!l_x`cin:/~YNUusEs}zk٤D]%UQh3 v 94Mډ*w=2ymN]M5{KnO]]8F)%jyD[ <=5G|[ruZ2vxkjOW~s_}eW_Gssij}EC{ԢUIxP{(Ͽ;_sy /S߃pG@}ڳn<n~ 7xRj,W~=?|A}[ⱪ/B.Xsp_ZBG؍ߥUħqsu=ի⟘ {{cv%$ao~.ܛ[""P9=3k_WOi/s)=ϋ/Nn}8^u=ܥm{)vAr+r~XW!ao ⡛:`4N Q^.s㚍^,lmUaWksx9jd%ooCWλ<+oM1ʇ?qqmS]8x% 8ry_'~n_ ޏ^+>,{]ԉif0'p O[AY=ץ]㉽EîVO,~Bwx!ZxG 5}_58ʑʗak/㞢~A%wWHv?Z/>O {.Wcss #}JoEsxϸ?4`']k4GjT >~CKqU$Q=I^=>Ӌ^U隃k~A,EE)BɏZ!լP^[د&ꈡY[}*oTW= $~⼧k =nQ?%sΫZ![T,O4Sқ>pȝVZg":cߩR2"?hS8AW{T\ P~#׭/ +7?Y5QFpZ<f]?H|Z4?x7>vX&b޷`4uŎKC|>ySk{?^qrEkW W_M}W}/kzXV{W[#U V|)?4H\[yQsVk0Qg|9g)xԗ7Hs%G-[߬|IN+Op꓋ipߛy{m[3}'de _8=ѪKT.S^*~<'۵ѧ1_qi#x@KS,PD"f'ޖe︫;칗.%oi'\~]pr[{ yhSqg|\_}ekɋ-d;]@'3RI<@~^-܊ϧ~ɱxh5~Fa')>Eꘅ^T ǟQKG{1y!{S@ިxpS8,nOdn?z>>{~*ڃsr?n[DӾ?mg.򏕣cſvkvƃNQxlWG/SXm׉?|}|䞩UMQwyo{AK)M}qA|BʻE1/r\ ڗ)J?Axu~'a΢\K|Ыxg,1cj|xU׵6h&+3w|{įWߧ {Q~q>7~?D)vx kO{-*?2_{g,#V&?3>{^S:B>+nP ۇRڌn أ:7ߠ8恚X?LzV7[o`W3渓<]4[x0ϙ=5#i?U ˱Էs"fVz"_^3'9yhWmuޤ˕ͼj_snEl<د}8h=[5V߼<"[ہ-gz}o4Qb.JP^i%~!PZ<ϑ!R>#} ڻ}x-yuT)\N?}ͫgSx[M\?8\'6?1L:vGGkVY;OJ7ڜY8} NS_Vg'?ޓs/Xʜ`eQ~Rs1ߪ~#uXJ'5gk|;ۿ'uG>/UN#֊gl$ yގ{(ڤ8gŷi؅Sk_~؝7]ĕVZ_},+_>ɠО5Xb3rvlߟ[_%o|Ŭ<'8g!y-dU>><WeO4%_ Nߕ%^WxϬ3ecKA)= .oW]=g#;<(`B C3OI<]T^g7O޲yW8xZLˆ ifVGCЧQ9 ^٧ {ήgy{i_p\xclk޿~c9_h#_?g9k?:A+{/ ar}^AmE.Y?)B\6?-;nV=pWWI+pCXu#@%1o$#/bWsqsSW^R=}z#x%vZ|?a52ϩ^' Wu˜ _mMyjoR J\X$gpϖ8fΞ%thOrMJj|n)cKќx5xHˣuw MlpMÍw;z\q~P~M%8xr݈\>>^[;_u>Oߧy#ۭ1zm=r Rr 5}5?8Os 9k[ٱK}6Im r?(^WգրCqO^wm/5'&28_KJ~vtNב*P<;,1o</E:8?Ea3@ p|Q9~Ua};w 9kCڮ?$ԃ|~,AJEqQ-stƝ??ů,䅊go "W~L}Oc^wnOr^ng#'agiYUnR=| sL}\hG'Oj!q~5OY=9Ue"?8Ū9]o!V#~ ^E`um˃⿈QW(_nf߷jՄ]rH;-I]6M&V+Y汾A/es'9şדuE߱?mˮJ_<N# [{7*wRt.9 jn? 'GUG'Eox1f^ٷ=wG^"TI<ذJsiNFx%9J\YN 5x}Z /r\SsraW[oěV:矊~x 騾|/Ӡ|/2<SkHꁚϧN,.,#_?Fo5 *[):{X \AZv8V%ۉ /e99@K.VՒq{紉+(}yėli_hs˱[ JcWo)e} x5S{jZ翰\|<٘x\7=I\LZ_y |u| R\ӹݢ<͜[^Y>/yi?|ף_-q| mpLvc}9Wb n׾ȸp]4ׂNJŃcܘjpOC{D4oȅm|ڏۑm)G3 yk'2vxFS( ޛNU|Ľ^uk>k^N<e<݌<t2x=8{ݢ47T^fP=b}idE䑲pUrN̗j^0GTn/+:.Pk . OUč~ݚ)N˷̭|`/szЫS8C^e_͹|Vٗsxvο_9>B|\)^+} R#}Y= ysģa<]5G:.>]rF4'9Svc~~8['$%^W=Pc-8!%>oOWqd'WS^3L4Rp[jpN]_|c;{r~v5*ϹQy~{W= 29FN ?ۢ(x_џO˜6Ctx~оa͍yۨ.SԇTLyZa,мR{lI^IsE^g\ kpJD[h?ײEmHDV?q Y~~>dN˿`nW?_ڢE-zLy0V&2VȄƩG*GtToPUq˾AM?cT[k1(&ڿPM@Kyr 6nB=!a]WWϕG:786qϧ}d6}Laju|S]cdoG|yF@? (M0% L~ Km)RKE^5I,نwbTXyоDHg$V,S8?w.*!5OAw_pD0"m/_f2^y1%-dsg҆y6=5.VIKT-[77.bH?peOԄLH&Y;S=Cn5GO$e?OydoێO,kX,]_|}Sk9ṈƔ^\W\5]Ni^BNi\S9mRq%gut߻8w|/$%;ԡ2=;~$E[6N7ڶ"E^iv*ly?O3MUn}np˦!Gɥkg5UZΜydlwrs&z"`銯6E#ԴzZMW` ^OyPSr72X1'VEx%ܭ8_e$pnhޛҒMU~^- Il53SdwZQs1%G3Dɞ3w?ҋu {^}Dq(\azZnjZ=OZ[jM=j@YM9ə+&f2'&.Mݍ}N'Z7Nmj8Sk<>M{ok$~?ea%#}E[dRC[א$od^g4yM$$p1S=eW`_>e^j̪3\5=F˰?<F_T"yڢZ>yjƎe!75۰+YjEˢ5R+2\-͉G?QlnO|9/Qx W- ?ur)Vܪɷ} N75bo]%xkŰ7[C0:]Ss1Y˕vbt_1kSś]+;* ~~-C[x7~H>' J70ɸTh!YEn3ՁnFYرGKD:~=΢ĩ&㈚B_-eo{\&HjzE֕:rŵMtf\9|^'Ey78?^^VǏMZMCx/՝jx&oДz<Ѯemem wHE\+kh:ˏ<>U-/jh^E"STv!U$*Ou%=N$DWFdT"&LB~MӒTS@h%.m{#ʓm$Ni1%nLnCK4`aȃ%^X$Ԧ^7d,ZHl%נ*{És׍^r yY*KݼkuL15-TO 01ߟ-PWϕ%ć?c6^L5k.0܅w K">i?N|x^CI;Z|n4G.Bo'Cr-8|8B$w8&Ҋ4$* mxԍEե-_&OI+ ʎ7Hc7^鉖d~jrtЯQw \&l>5of5]ˢ_Yn;?~8tv^g2>TQL~.MJ 5O|۔_ ~MW"e-[GLC" 9&k4;фv/_`kCSAx-O󞺜vh 8lFȄ"OKПW$) w{Ӓ} pc%ec"W2-ՐYj y#ʇ=Rd_MQB;El#\K[ {1y_ y~IRIY&sSrK4 k,'MF~B8%QΝ0De~нVF:oSsOjn]N5޵#q L>R/7+_+ZU?'F,A=JO>x(%Ğ*-/+nԻ `n%5/yظ65$(m_l*U/@ Y-ɧO%/8͜Gs*p:Y/oas&#gUݕ܉= ௌKx9n]n}$2 8'ȃ_%?i{skQ-HcOL5pja/`]f Ǿ%G?}>$Gcj6yY8BHEQ:JJD\R% ,9#~`5,| hx_";<T_M zoQ"~>4OT>w7\ؑ%!'e§i5~ %0"׍[>pxR ݟ1䳬IqJCȆܝj8.p= khyXCKފOw]7|,I3ӆ|՘TGǮWN9HEOktҸsko%_ٔ{$c,h *hyrixX!}yOyٺ" >R8)u@JK7p#ߋ5\e˱[z*?_ԜEukDnȹ54sjo_'F! VםCƗ][Ӷأ .8W~.7LG֪<@]>aOZ}/_-5?&gsr_RE*$@DrVT[zC\ϥnuv!: ;m^uj^Cmn%*fpr-Kͤ9n@/&@_Ϧ=_ nHnj+i\C-hR@C]exVA-qkT9B('OjNsix=#g;b|{448n4>S]v=FKÄwR_N&SNw/kCody" AxHhNq>vga5vZÎL`8qç9="dw!3va]_xy?~9sO_}fM*paQ3=fYa{2'Ln;'B~sdt4Hն>\?3؜L{uHj2}fqwH̵.'id_׋=5EϢߍȻDr#-Tۖ8WpG‹??زɲT"#UWw ~4eiby{E}g_j)رAȽO ]l-z|9iOuwT\0<݌KuEwy5w"Oɾn;7)3 ˽O㐇d>e?)=S>TWE u>}4(r|Qr"utRu}j<:tH8 Oy)O>A)u1 sͱP9jHKȜjnT!˚]7gt)znxWu߬0l"WSK?}c%yn-q{]asշp8~7t&Q%5F M<~yXd#E!t0~6U goF/zUNc''a~ᅼ9Wa a|GB.U3,MCmDZe>~/ CQ䨮 <^ "C&95r}EoUt.S!.iݓ*5Q8U٘%"SG&-G檏;B||Myګяgc޳s]~Zɽ=|?Zk+sRXE7z)[vU ?n;6[ nn7;$98 Ύs &/P2<'_zKM=~WyN/~*"qo1v,[ϙ 5DSC䳧Ւ6:#'9sJӤԕ|+ENO}`{迻LH]R" ߌ]OE4P2 [yn2o~TI읱~D+/.FGnaw%Dc.6<g4X=s׍7Ӓ[Iq|?PKq:ilRsƽ[up˾[,Ir\x1K/?'.U!NV&먫%/Ng˧e+fi6y-٘SR[%b|Quw"I<6ӧf{kUxU1\C9Ofm]s~|{Ky>i34 Z"i*oSK6\{fZ9qVN8i祦ha ϱ}NܘӲcr<% K6cMGEd&i-[Wney)ߗWF^LyzUǐbܶJ y.\aJ-\E\ův_f$w&.G/R/׋ni+o}LTDN+Cs*99H_EП ؃5g>R}z|/lyG~fh_%B+yͺ2~io-e J~A\_fa1>u )5z;[[i#k5/+N~DwFORz=f9p?,&s\x2yq-Ы)Ns*S0&rsAb9{t9L⼧uښ9UINjIw:ie\=a / kW*V1YGwEKL*u/WuWr } 2s!~};4!zn^{lXfk| "ވ>|K)FZw7υeS/@܎NW /9&A7h9w3F/}-xy逸&V%{߭B,k1TF4E^зK~FoQx˜ĥ?h8j+^=~-}9(Zu40~D+2…ɷ '<- "7әc6Y,} lҝxnpaQ-1oyc_VkYx\cP;Tݽ9gA7o˅YmZ>>rfx[a2.îN.\bUJU'8)?Hr阖fwj&~F_MzuxYu"g MY"4OA|E\% OH&/ڦաW"nϹޥħם1=qјjF/TO Wԩ%(S-.f%#F'W~@~#y‡˨M-wBҏ[s WϰU3*EG|nϰ;K}"G$ȳ{琏 36:6c ė큜ޗ#KUjid&xdz"9aDԷ3y.}$Q m]3pYZN嗡'Yσ Wh仺7$q8}LG'`;S<)~$}WXGJs"u`̣CT'z<^Bqh5ա[iY%4^!oҲy'G'B݆7Uxq(@C/ Ϸ^$r|/o/"o/&[h&3Mn'&fij9qSoZT}|@B?젺]VbDy6kyJOn 4|R|Ce|+XG׳dW}o Lx`g?]PVHJo^/8zBˊ/!-}Jy]҇AKI|θzꪥ^<. 2 gjT;gX{HK GAv2M܀~]ޔ̓]ܡ%a &i\ZCU;^2jh=u!zoYsX=wgK+EX |圍\ǪL޻V|{zO{~8P_euizzR8X?'5G"}TU-W3?; "e֜n%~vCEZ\uu̟xӜP-TCI u[ZRϩ|O</-ϫ2iC.^)P5y'K\Z}ʏ~~ y2*ݦem4►nB+_?L=2-+t.^& > \knx;½5$ok/?I#oF֊G1{4όf*N,R|yvkAE`aKܽ$8?~6vjvdµ|_l!Vc{jwo ~~>[C \&͝6+,OC ԉ\OIJ~n%|짥XZeP˙Wpz>Zz7v1Omu*G7wz1ywvZ"QAبn qoR'35o x9q\pB4_{)kGy/r>PLa*I>(y; OMďYxKHE7 ~9f@G^͛*f4֨({nGO}$?4Oɩ+`k+vsn؁k{&-9E?3ޔ/K0{w9K SvPdaNz#7Ϻ/4.h~|4'Nm@JoLޙ-{doCDKnܳL]k,1Elտȧ;%[C6&lBfk[(<Ojv[".K>oaw:cLwR/ogYEfވ csjeSN<;MHq -__:c DbިZr v #t\|.n>j - ;Mq "xqy2rZj[qx*vhnj:UΡNէ%٥QP+O[G8DKLk>}m%2_kO%WN*p^͸.?ezo1|9Q65GZJ{m%q[r;ԍOEK~RlV$Mi~cmt0-#@cLDObUkY? j)Lb3y,Li 9ɽGfjnZL 'F݋yk] ! }ՏN4w#׵|e<ϛ?Ju7&v&0y+J;X yw]=# !"1 p[N;՜ U$-:ϭY`7{-H/[FjFoKYZu#mB7vcj_Qï<~d%>8s՛NS=BR8v.rn߉yW_ʧ<[ww_عQ)I/\8H&1Ku朢5_OX n~{Ζ#ߕsw)zV?nyģG_ՏPN{͊)i;uk^&z>[r r\S9ԧs 'U?b}*g}^"xC!<ɯGs.SP_ ?~© V(dhg`_[5ox<`'k5k#^A:.S}5/gXx1g;zh  n sp}m4O{p^5S8&~E\ oVl?"G},}yy MMoyE[{Z2=ܖ3!^G?~+X#5݋{L"gQݺF;?VKRGd#3%}N:^Q?BcrPo;{l8r*Sj9Q'=v4KR![MwMr#l7C@N\ڏR4kPZAGx٭>4ϯ+OP]S=;0g{WS~{G.Gϝ?#g#"u~>F}}+O>嚣5 {"Z|Cx>y-8>MM,@W+OCW3io ^3)\~L-SBps\ x0p=?ox-Z  ,ySʷj1j ?[T ~FD|pSӰ#UkT sO܏.2%]…Ӧmj<zV6Osk=^u00γ6ʎߓ77w&>X{ˊޖ^d-yZLs9|oZigR$˨mpTSEM#_~N-x*x$Ws5;Nn~S=kׇ8FZ}sg`'D+׾[ɫV^䘫ڟ) {*ߡ=-I -= =pϥ]x70Sxx ^m}:L%[ pq&9Q#w+8r<~~ )P' lLy'g#P5oA̅} &iܘ=GTG^$w^!Ρ}'Kg/,p SeLAWARyn݌UՒ}ܝ\-.n=eԝqQXslusKGq ~$ݏW%|H'3L|Mހߨz\z ϓȫW/zY6| T7)^VkX˜;'97՗=ʻTM<*CԾ)O\u[UY|xv,ߟuw28aϳ7%Sxo)SyO82yhË Sz7}'8}qϙ#u7El85}5jY2  t~rή _#h~ָ9w>&G3%n7Ǵ4s_*pO0|Zx/[4OnMEm{7&E޸Dy0y opiO_1~4%;~ON[V_DgڨW_hg^8_toՃ;aA\F)P<1e ^ыK״7ɱ^?}S%cC#;#{nErUh~8[O9*x+ᅫ$g#]9|#_s](-+{kPnb=Z͵KI3>cv0NAWqG|~?#TEɫS7<=IqH{g%3UyG>-7QKe&6xR%ܪ\9,*2f_WνR(?+q?\#c$~[[cG OQNާƂ-p>͑zgyęIv x7]]ЧD?Wuf.-|{3_I)H=MZIP+~泐ӜV&QOr'yog0zv}i5L?9=)K~vS/:E[ɛ?K6ynf`=]{_5}6>z?U{:w /S%~Ҫ;8]ha}o][|Oێ{y-ખء0G? M";-83o<:w k=o _{Pwg~Hss=;>{Y8~s7{#7Ck+{6ozKP"{Iqkw5ϋ>'&9Жs ܁q. uNpfb+z\^|}E7M+*eFbbGi#ڏˠNdgS'/4>vم>_>bf/6ɻ{Â|7*&5NJYĿ[MOuݽsYOs.l9o$K>~q`|K;yF:`?3'z&_8?4Js㿫ŧ5>4oJ5qQ ]_)3Z}s oN~ōWNAOSȿx`7^3N_+W$ͿDK!w|󌗐J¹ŞC?} h=ϩ_P\})NyƟ#{_ ><,XxI<ݚ+r԰MD[i^=gg&zOOT] )q,?|Bg'Q{jN:]ɓ-+ذ9a"pvD{B/G_-~݃>S^⃞e}hRJq 7wA UI[f> ~cI10v3K5߳?qۅn䇃= _bKzOdQӯzj4'TN|=!GUzWc푯_c,a}O{zZ"؆ݯO/$^*;QrKgyR5|_$\{8!?;1q1=MQ>hςiu}߲Bdρkvr~ju-^x1wH>>׸Bqy]^ I_l`0z \dY6h5s&眲k%x#5?T4WL1R]bpAOo cz84|Z~A,> Kin)j oͽX??I/ŭɳW5}9ŗWKk[9r?S8>syL=->g"۱pJkpPKC3+ڡ= zL}n)?iWx2h睳]}N=#;U?*7U)5\yqc,^ƿE82rM]-⍺J\s?A='׬h5)5\bſ\h?So7i'!n9X;#7銋w.Y|gC_I@+Or7'w?WS'2зxZ{?kT=K`ߓeǼ{A|a}WL[=ZqV,쫹!*Px3ÙA,ќ]g/\pBέתo&ܙ`*T[y@-v/FI+7v?ܯ]|S֐'eԓ mea^~C{mxڕsysSJ' Gr_4d<6A@_~[osiy-wFn6~uӹia gORϽ Ć+^ljWs */:y z2'v߃*՞3^~%[s~3m\XdK'o{yV>!_#/a7~-8ү9GTT>vCmء[++9g.6^$nߎ~̷X-Ke>~B}C7}oϰWz"¹ZnhSB9CKEGzq%!䥚^wDz6ko#\}7*?Ƭ9F>* V[qU18{DygG oćf3cu/b߃3W0 ?g4Ǝ4cg3m|O_DWr/b(` Ns)4YLVX@4y(O&cD|7N|x=| 4ů%>'H* 8-ޢ<`΢ >. j#2{W`޷!ēU#cv`0qhU竟:zFQ?j _4Tao澂mчչEs5I{P'sB..jKtV;Sz^3Oj/B=Irb~$׾g\N>>GߟSo3e~Hud?% +WL_Q{?陌=(~|Fj4]{[~YCcǴ/na. .o\)a%֜[ܧ{X7$\8/MKi\_pd+4= ܟ<1C>F ͧz~_k'%9{7Eo6$Z`/qN+woi ^7z]y$d3߷h*LjevVPJyse_)Ƶ;*! $_l/ԫ9>}J"*x+KWs?TgC;+a/#ߊ Q`!qoߏ4(E&={]>_|x!E{y>pslzY:oxF{bG(V87GI,ާj.n|o֯3/@YA1x;xk3ʽ?F";(|R>I={>,e'~ַ|/&4O?jTjɽ*l!'ys5^x$?$.q`yUcs9]~FL%S^] lϔy&w$ȟ+3f ,Ρ`3Dk~6RW}M#lkOSpSqͽއ4@?w͓=X՗U}|;_LEO-{Iʏ}3荜.^ է oeb_4&+_yp_ԼUsNx ;^h~Xxa_   75mk&V(X߱?їz;j|Y OU⩪og{㟐_'{<ບx+co//-TfF)~cfNi<{6RObϕI/]y_O?zo9Kȿo־!_p! wާ?"^o!2chV9/5>;U|fhįxX<ڧZ"8,{QLHA< yK}O^A&xYஂ>f r֞MOy?4{0:,o-07TM|ݯ!q-#ڧ8! {\x1Ks Wmqȥf '_ߓ<^J&Q<7߂a/i_ij 0VsQo$H/xE{~Ergav kWLFJt{x#ڃ|~srCT'/=O_Bߪߠ? qaE!C8y u lnS^b0'!?8<'/D>h$Oo+kuCӹ+Oh.-r4`a[^.~vkM!v"=ݫ oM"u Ś_yBcfawwI#_oU؟:+4 ^ѿ)~na.7hD4YFzLnj7O6zKÄ^=)u'䡮a6PJ<D洣wk]5R O&w kjry ]>o܋|Y-ao%T}[h,Z&r[:<ڊ1? 8?wgxs.k` &.5>.CNF佄n,1?Y-8G`'.ɼIVq~|_ۨ=$/]qn7eSJl\ SkO?~5y?{9 3vx@Y }!ةaMt_s^ؿn>"nw+~{T}K.5G5aVG qDQyuGeFs=؉웷ycЇIާB'un{z}v6#yNs؎'(xKw58Y9P5qHQWR=O<OUrzG;C̞M}Rw^y-sQp *ܒHj`ys~O}F<̱d=ghi }*%4)f83VGyy > }ݏ5ͼb"ܢ*O ]SJ]ӘO B|^'gL9oӜI >x)9J|GθS{Z_o GiG ҷT=15{ѽ'~maLP a?ӢNۨ{}ԧ"hUGY}iꍼ%?>{r$&a=:zSX{x=Tj(.74 v5wQO6yU}_;5'xԡyӐWgϑ_| ڳNu|n}/\*V"K;3TIݺF/Ћemd'~^q9/XOm>~4bb8{x &!ps|]BqԜWʧIϦSΪI@S}~Cga|%縇W H$|qA SN ޜD[!i|H_ G5k9P|]M~c|O%oGf",#Fs'f o&6D)!czגO&xt'5GC;p_׎8y?wj63xb]͛.F>*_B3ğ\=b^͏7~)^b˘%ۊOa s՟j=أG}7/7ѿ* 藉ho]^bjXyz꒾//&H>vnP%1kR{5/UO -8}&㟡_b#Wc6Ņ{zLxϏܮXUO ;rth!vwh>hKs>x͹ r;C<L|u޿j jsUG__ h |suGO{}V8^sl~%صTD+xFcq!&"wXN~GOK8;]e_ο$~&F؊SUȴqϦ[[ ѩkg˔N_Gx\}/G.oتyK}8sr2S[7?ӞDL駘1iKh3/0v8= |`n#G?o|JH}3/=wאC^"zBϔ| ?}h9B7CSCk9Gn*>g L]7a484u@l'7S"ނ7[-7M[N3מw[{75o1:o_9fרMܙ./ۥ)/+?~bž{kQ6&G_ om6?Dd>;c;z|N=G|{0tswBEߪy;xLtS=_eqWhF6p^Ri׼a9>!k~~Ѐ\Ks=I{#gsE6R_t^j[ 3;^DgF/G'V}JsZ#H3{gՉϖSޤ=n[׾иL `usyCQ>."N5|줚ȑW"pjEuo˿G0_OoN/_/QFVok \?kYv"/>˸cys_K$F_!l^U'v&TWM NU7)}Ng)^)kIkOݠ_=S?N^zrܣ} ~ί/U#ϥm?oe"3ރ/:xX-͛OLDbb[ԯGժ!OFS#~1quRB8!OsFpS+_\e*^kÚaW_ 5)ֻ;9UOsOދs^Gyb_|;B,x?nT_78NgOj?2dQ_x=Ji/ sY<ܗ]y9S_z=9Q{q9KQghےO7^jn鬸t< 9&Obk0Y>?vxQέ*~q RT\n+"!)ݮ[ṴޏgX|_aOL_s'Bߜ?!U49ku=%RYF$ǾvQ׎|_J/kZO.æsȓE=v%o^5Y5*cC|aspxLZO!^,Ꮒu:,oσ>ş!?8j]24G]J;vG |?649#09_r^SigZȋGd4O)sҋvq< Z6OyMk|~CkuM7m^G ՟ F +/t(.{%>S]wu yiaYL|Z㚤xAbyᥝxLVV +M^NyȳE}ɓ3'TM]sF^{7R|+ȗd5󩼁 Z O#z.aO8A^YmNܔ^IiVrVݞռ~FMaOc/uwu&^ǥ> L5Uv>^7/>#s #?k=Мܯą~e?_{T?i+^d!!^K:ݏj/iMF~&_uǮWTGOuW%s/1QʳR ܫ>[#Q'j߀5[)1ڻ襾(slX`o6n9GUL?܁vk&_Q/O.n,Fo2mN'_o39D.#}Vֈr~99ކzrϣo ү|͗ bi3pPk=~R,?I7Oq'O ^κMϳIO#iSN=95|oEG>E] 8Wx$x w"gسcaboRGVJ_&ʽ%<'&O4Dxuڐ-Lo3L|(FT&w֞O?Cyx?I~r }nk;Py [A}<%ʓ&WN-?y*;W"՜SWmOdvU}o9o/GӾ>@}-*# n?=FW㯽;w}Oۑ{_#q٤Wl=yzٿ|W׫qzñN~~A|m؈Ykߑ߆ʿ~4WGja|ZB\ſ{qsS|yLEkO"~]ڏEyΡn0~&~:ʙ wwP_ij+J}O 7ֳJw7[fQ^R:y? u?g:y~Bz·k49X yD7>qǘ/G_X~ªa2Ka^Sl[>5P v)dӇW}({F{WB͙gQ|{~YY\SGd1OJvBs9{G<{?{_=bBV&coxE}&{w S^);yNx3gkF>Ÿ&"x ^{fd[Xskss;`{& q'nƎpuү=Gܹ/}]T{y_s{ I[3.nQ}x;.BBcOHM׸ǁ5[|!&g˫9#Vyk}`_SH5s~OWMO`G{?Eċ)&6mPFFḰC|gTSOhF{w@.hĶgS~{?-f偓,hg_p&U84i=O"KԼOa&t;Uqջ*ϒ_ڈL8⑚?z [+@.> {XKgz?|";e[sylp.^9Wn9bE#ڻcR?P<$>l$e o&1ٵcO[6{ӝW-)U:Bi`ϑ^,^W;|ϖfV0c%ӷģwZTbx鏽n>W֒wy b"Uo:bz9v# &PONA:\A,[s 499G}.4be/*YqMȥ>u.:{`7i?uf򏁮2~I VG;Ӕ ދ5߆<$?(x3c_G#2MV_5ޫX7 2al?3*dG|c'H=%|Tߍ݌<k,snQS~=RMNTUUzkۮ93[P00bt%O!i{$~~<} 9'+gke䖋4 Sk|iʫUoYNW`y_ 0k{~S̪} Zl؋xkG,~LEat(Zt yexi[|aWJE.J2[c/|C9 ԴWM5e4Wƽ:"ߠ.\6uG^{:gn&>V;3Og)Ob_Hϓys.SIj?8޽u!a}ŋ_ (qqv罢?+~ kAGɮ=EK,ѹiqXX*P_{RQI&% 6G^hZ3}jBv" T|oK<"ɯ6׋j/ן">/4ZHO1ݫձ==.^Xf״.'РF+޳m{\n@zzo-Z}GO*:o&\;Ai'GKu?׉Gfv!Q βّݜy3տz;=fv'*~?|Vsxꯨ,to_J[k2;]5:ib~0yϞ~2}qRb'zU,lN>ԇ7hex'/Wig9)> [>-T7z_{G8WS `Y>br^9׸Ńۂo޸ gsX򅵚L硟/c՗|e]9 =W/y;,X K.͛=9<_YOG?~IJэW_j-aL\};wI.:i4#c&SO/Uj\s_= ׾5w"qDG._!yFކY9$w7>o+E3}h)~Jy<^=oz/G'o8yo%i~~ıY}p|'Qص^S_WnӼG,a}g"ER{C_ ّ:1,i. OzWR#44&3v(zVx_KV>Iu^7Bao<]mȕewz>2ϥęQڋVN)?~ #B7ݪ̵ਙ#l??F'y۪ԖI\ȩ=|~ ~ιy6Ɵiͯ?2.S4Px7(_]|1䶡J Jo]#13Ê:*`Ɛx"uڇYԎ)8y9x:<cY5_KgaOgyؑh@fjW+oJ'v#Wre+/|zge?E>|ns;NKRa2n yOmT=^yǸxz1Kse^#bBkշ⭨8B~a _uy5/7J=:8:$hKuΫ<=>E~[ f7xwipKFޭOO{?WVx`W.Qcf{檏, iY[KKJ e~DuK_o`PW|ٚ:E_B;ꟺy30機5r9,;J+ӽ;\E~?'v-ԗO?`qIFϼO4ǖG| 9p^ɼg3zZ?ejZ7+_| u{>g_֛A'm59 0Vù3cS.HMW>v'5?N/iOLsF!:fUc3\9<7z{96,D %}l<(zW>0|c{(:~?>Lw-zA~pf)6WrU &/?ni͚KоxD/0xaާǹGbs ش$W~f3(I#Z.}')‡_>^:ϙKd}>V>Uz~nW;o{ 9gR=ajo/1uq~>$NV+~ૹS,}J* yV*B|ijMq/w [UoV\:Ui>ڷ~xWYD>; =66[?6.=}>╼L~BpYfcF9!WU_7& t\AqҺݬy0VmB.ooVqzx[%yE+ʅ|W.ɇ+!pRVŰ ?Y=ׂ\v\̰h/2Th_s =f?{NQޭ:E|Ծ!7WķjŅ Љ3ko3P;_|1Kt3qKd=ľ ;?}!seh?\vǙ\>ϠXJv+1 įgGzV~{xXncv*N#|Wd7x6s4z'yp7S]ܓ;Gu+T?/lEx! 4Sw*I wEE7esgjV٥:/8&K{*W?;y̿9W9oM#u@c_Dp2z#bŞY#ث)ou:W&ˉkd/!n>} }'?>|T}8C3߼g>8#:83B{\}WfsܔH#?}A]O)o.8?W;YWO׳̟xз {8W!_>SW`.׋s 3Gpsҏmy_NfW{S*(古{}W_/yqvawԟ~#K09Y&{xC>>z<^) Yk0z:ˌ{E_a]-=;~ɌqyZg*jsڛ%7O͍_9ItF ϫL?cG+U4 f~F~Żw{0qq?*_)?";0T{5vҕ>u*\{#+?{b3Cyy|7 |SK}_b'2bAjWh/j̽ފ^>Q?hNrNu^ڠ<ֳ6ܵg]?A|ŹMܿO~fa/}_x@Bs~;7zRo\Wܜ=[›Fb}kVC-㸷<"v\]ιg;6{w[H(kޏ5g[7H{SnEr+^s|:Q_XO5̡/׎!?י9`{@scw{>8nz/%No+z{ ^G G8Ԟ}.So󎼀O8Wv|!^QsY{,fYHb{=_p8GxM)Wy ong ڧ昽UT>3_#ka`ȹ9aǢy ؗ|XwG}NLmj<4cu7o3}yw9w7iQ;|^!2TC}C71ky/c/_kg Ǒ?E=țbeXV2޿r4kAӐSB՜otUf+/f֜y+T y#_pSUչO<;:\vz栬ǰƹ~l/!Hx/4_<[̟ES,}|nZ잹Ty;zpqe*^p"xɵZQ9c39ُ^M 6$U hީC pFteڗKi܌9{:>+8OfB9k*bnOL\-|ېL\pSb{S\N)k o}{|WkPM<{e$,w?SSyso5B3x:sO!YRm}Ac@MB֩zlݸ\ߝr>/4iE}89On9e|Gx) ($Yڴо< g6;|L`Wʎk?7_/g侅Β U3@~vvƷZu}~s\ν׽.>D<]T{$o"e'7!gL2Cxי{ gŢ=&6i*<$Kgy֡k;:+uj,/3zp-ڃ+yty5ʾ?Й&쬯Q !uj]z5{\#8D\|asv>ɫE~9ċl :t‡xZ3uio%S<gsF~{-ձ 9+{d|*O`_7O/s曉8ح_;Ż3:Yc̳;ȣ݊_M Hd*M],α9s>hOm8tffӵSi}El ;C`{nVnYl{8|觩s+xwζ5ξx̅[nn}fLŞe":oא'#N!  "~ܹIr"?E 垃p=ozkOmwڂشo~,.zoQ nA 3}y5(s_?TGxysz+m?]Q_ 6<\ Uc;!)^O}5g_flUGe5i{[ MsC̟L[|Ox a }A3aOR7 7ꊜUܧ,OQ[N -~+lWC3/Ϫz*9O^%;ϬJ#Gb; *ߢ>7~.rRC_rH}o#$n]z̳=oe['Oz M'+e.[B[_e%G}JS3e~ |`+܆~X# ->D;?]/U?k^{dm܋,ER-[}=q+Pt ; U7beO[Y}cj:s|FSn} eֶ<ߢy`g_ dysY)t[US,էĵ+ ܒQG?F~!iF!.xg:䡲/~r[|TxN!~k~켹/~j"6 ?E>o94:g#]cCU:|??~CN}ygMk<ݜbNj&co?dSUrؗ+ϲf^Ywyɞ"ԟ?46vwMyE{jn[hF@{#mk-=;V*豥R6= ȳJxP|Jas=< ק%9WA?"_k^{z/zPJ> O}|~oз2':":Reԛ\qpxd;;kz>^w:DrN)Lh8[ؘe7UȵY/s?_6/Yk9~*Ks{/cy,5{5 ͑'~"qdā>T7>Ǽ79C5>xG'z2c>U ?n. &/@2/Nd>c>q8{O-rc̛i SeO65Kyp7)G;Gמ]RA9⿦Լ nKZķT=U9-]/Sު(93U.w7շ\]x襽(U9 c2Se'Ws"pxZDnj@ޝ7|Uj+}V}%G ѳ|gcA~e눻 pW/R}숯d~{~{@GןxCO.2VQh0^yYɋ_.^`S >v^`1~ޛ;wPJIwY OߒuÁo}r~o潲Wߒ[ǝ[L?%{(\gOmM]4|C\^/w ?l?0k7{Ws7Ws>b9s? Qj2 .nOM@|׃Oj^luߌay2gA|9+{!T|\i~?OuG劋oZ .oyV?W'UHv4zcv֌Q|^jIuzncڢʗk>ι#Rs yg zl4Kr J57uD/`o7Myۀxk{ o~3^%_8{?>:z_/ܣe}3G(Ё}3ܛu<+Ы2W=sUv4C@r{sjx|է}&zYBsܹ?N|x;׃>go>,8f!_wI2VSekH~Uu;?I|uӾ8**ë_zq&|ʚH&z'ŸJz"DP@ ɹ䙎CUwWUbDEĄ ET@ f>E &L1@{{]Y7Rxs4V]K'kg~~{ܤz9tqރ'gk[_Ie8+ Iܛ)\{1$9=B:"759ѣ{|KkƯRol|xzߕ>M; zDл|ؾgc^>=zNzqjཤ_>/ܻJP>yş=Bk5|nfI*ߜh8\\sH[Ʃs\(^7v)x"u~ً9b'C[{2 U ;~_zʳ|2OgUgi\/>VKzuǨ~0'Y^z ׸E3Y7s8V3t o|^@5r3!S^w;C~xøs`>l 9r{x:)oپ̑:k/o b4%~Yi#fbR-?߳SK8]:}{7"5c2͡w/+FM`ćNuZkg _o]x9܏9xp/v?WSpkة^ęwWo<y*/= XOUvĮ5Zz3qdf(E_^l?^wC5 g]*kVU<_uލ>S;]Is>ͅWǎb||RFUo1+ OqYkZ< E%W |n6O~3gtݣso8e?:U /` /^n.$\!^Ϙ̟|`?@5#$s|0>Ec\}7F04z3B3Kbhί?e݋? } NnL~/1p+ϭxLuL>!{o3EzEuzNեqU?ؕ:GLBڷ"> xOwVq<cJvp{ XE.q7SDA<X؇Ήs{$i ߍ ?TȟWվ}$!}Bo>l$nm[>=8/Y2TX/+L+tT/yBQRΈwˈ~Ojn1ijѪyY'2K578ߛsӢy϶y|Od)P<<:SV{ㄉ}:ow㊫Wy隋yԟ{)Typ7Khgrcׂo?<>~u(/9r ~##2ST$rhlx(V~j&Fvs[I>?k:F==r>ӻdf39dɳeRh ߟCN\ $<@z+sKP) GₜW|7%Nqe$knwb u>Wp =w/h\}CUܻ R61y5܋гORɫ+W-ϋoE}~v]9^^?S?05QP%o>A}xa~1Tݭ8ߞ׍ð}ɬQ?_t 3~xО`SxNջ#7&ֳ@OO[:I}kɳob{)O~!NoWEӜqA j~pWg {`U,6m9$,⟚|7C@ >W /w[q ŽLG-Gӣ7Gyٓ:ֹE9^g8B*_g'ZWCy߰x:Z$E|Oֳco֜]~ߍA«xՖGlz 35K}i> ?]-~ACKe}2GgV'CcXNpO/TF:oɵ~^sL-Q)R o<{$1^f̱QkKD>N=`ΐ֜v8BŽXp%Ϧ~<%r҃ZyȒ0sK _½ _WsG:7Y,{t!*|?F{bwP|Q⅞Ĺ˿{o%^6C%{pO+_Zqڋ2Uܳk,Z%ž'~é/h]~/>Z/%W?KsIKoSs06=ܜ\[VV}5хHd7& /|^x[}Upse{ѢM<[}/l&ZUU?*KpOg_Ge37~ ܐVWBWHϺT~|هH^+7?\tj{|A?.KX(s?(->)s"On#~jS#x37VNw o]*H#=f'i Nv`6s;pf3bեJ9՚Ɇo>Dq."gyJw`7wPkϳ^sOn~ <)fn%>]yV_I⦛ģ.嬇7zu3<ǒ7 &E<_5{4vvYκ:J'Ry {l<~/~+J=6pfGr{G+ xĹL緱g]v?ۮp_kIΞ?@s)Q](z;h߹IMe]it빟{l\ N֐ ˕¶q+HywU=Ϗxo?&ԋ7=S^K/J_yx+Lc]Ar$~zc}fSwiḊsmsOP~6mu5GFٗyui?s\%F[yi|4=u=}*|,g?97Io9aֿQq99<ÞQһt(Q*bQؓG[3E"ۘ37:>^%?į!n /O_渎Թ,ݟt-v3o)~q'Ov~*Rrvf4Ba3=BȷW>fїc_D}0ͺLz@C8S٭_Ψ_#L=6iE8 {&^5έw ';o>wOr| /dWrǷuK,\HԜC-:Y| >/Sϝltf/Wh/| Xz"}ü3'%}q Q=W}+8{Ka8ͳě"]_s x&y;s,Ǝz㟰ę;y_ãy¥wga'P8vw΁ObJW֬&KS=Ƙ{WdݒmG1:5/[_'/{7]CuWTTƣ9Bc'94˸iOF gǑi"R=(>?fY/Ofrqo?ǃ9'U{2W+NkƞT~% Yo&a: 8G{ U=4ʐ/n~{>/ז:gSfPBWhW;BxpMZ#"~[#;WzqWɈG2v'ԭ@+v%)7MeB䗦ŸO^o_:uc]݀ t[^ŞΧhpU)6`gzCyOr #~Om2]dgx1mf} wqcKK|~>,^;'?y7Aeݍ3iW:l\_M>P?y0yZd1rv Ѫ=}y^.Ί%p8&?bOSyb3xa&I*oYtn n.]Jtbbgo'}5Xz9dֲ/m.7tVgki}k/<2=_|Q>NZNTzoɾWy%ꧬ_}oM'u7u%#uȞf.tds_}A˻TKw0캷IGws'*zG }&YOωU_~\|]ЩџU3\+h=:ߵ޺H^7{OzR8םI_'/CKҿu.ɯ2܆m<Q58?_CǼdPnfdͧ>U{x>OvpDs}N->(gO119k$Gi>$/40FUu0W?独þC ?Xjߵ]V3L:d_KF7ݏ׸vבT[u?=?ʹtŸAͧ`Z79-wϛW6+ˣ$(}_k~KgBuKhì_|3sGsI۟3,}t{ DTϝ=rYιq-/hͯgO!o[Mߋqx׀;_g>RrK_H?{]<8?vS~x 8I|>Q9zyDzw8׽uLu"x?7_c~A95sP'=y>N/q>{Ί7V%- :B_(^!O#?9ң9̝~ZQӊ?n{vsOg)=:x%Ĺ`~n&g}Cx1xOQW4錛:wF` .}3z\*OZ y6w3yr.CoҫG0zgi)?i?~剪 uwL͠[.w۷Nw&} v3CYӚ8Jy q7y^ZjӿY6|^yONJIT߱1L RnېU-V=wNo:q^m1TɲQLtv; s7:yWw:T7*>8 Gجy][5o)d]mfQؤ~5=gOԪo&s=A<82$މ/C43?s`8v8x}#q_~W+늘wWfsx%xN\EC+vy ܌L]~@ -W=GQ<ܩؗ7d7GK7+U0}a2{Ng?i6OyF;Yӈ+ڰQTkZKb}GW.GA6XSݮ =X}@IM '/wL%ogHG0"~5[|ҏOb˔ON%T!ߑdO~UTD\c%n0qu I_Dzw){şи֪kȏ4տU>_]H~yTcgMkT)]NJ7jѡ#5/Cb5>4xͽޡt}sLרozJo%ϜBqѰ@RGO)7M}#2 Q|+jʄ3|-Qw+_h&7K_s)yN" n[H㞥_ۏDݍ]C:&{doB\OWD5-i3؏PX:P+xϋշ]:M?L/t5.9>-=s~yʰ)_\_>UNKݚ# \r-oP߈y)wԗ%})R?*E??o~s*!ٴy+B(? b=YXbW8o~ݮW>f5߱*a'9x_[:???۹99_MsP4c&]ҧݛxGzgJ#w~/kR>TxL_<)(fMu3O2KdΎϵw<-=)\K߆y󒾏u _ܿGv$qAϣ.H*`ʯxH<܎]m7/~No\T9u7ԇ:XNkO\:[uկ r[R1+|ۢ >rxkPVgŸf>EMb?ROakVEmpϒܡ'y_xKGk$ߟ?gڦ3V&ܯ5R~n4Otɭ_;hUaS܇*ŧE֑J\տxmǞY #=OOPXs`Kϱkx2 >D7Dſ\^ٚOH/#rovzGQ=__T49QlxxM~ׯ{~kWOXF = !|@MM쏟_,)H!`#YG?SHȭ{9#Q-(&_v|~fS`O/{?xZsA0GpGǟꛐC/|&'p,xspm0:z'eW\py"?K~=#4)<_u0{~;3 ?>x:{<O+[׋~Oմa?,H)78wSfI?PuOǘ竝+%#"ҍ^TI"΃WxBk N ,{W•vѪõ+qp*iuo6+y=Q#=O%U>\IZ7p/kGgc׳gL7aӼ: ͳga3^y^ͽ_$^N#ԗ-q}M܇d[yBvv: %un7iHsN! #]+kX7j.Mt8n6WD?ae鸔$%@3+S1@sW{9 $=ߘzƞwdߌqUcJfq}m'NǢQ ~)úvK7\H4>V/#sN0bڶSj։w#d 6ne}3/2ݧh>e8Y ޅ3Cpxl ~h<߫;v/]Y >L.$OPzzWPg4Ϲ^Q_O>:FQ+K v$V|VGs|Y!C韯~{]J\P<^|ңnHVy{;Is빇ٿcSG=._6_p0ݶ؇̓_)>G*:.oT?DGPW> ĞkOxoQ3U O.~?VG{@9㲏sͳYk5G]<6xD1;O|34/i^hɣC^d.{;}tf/2or}+^=Xb4;61XGyu2?c>2b\kxBg<sh︦ />5p1˝tZtIV4?fģUޮN\K濨+]'~¬A/\wU#u ˞/2չ-3Z'2QqO yg4Oz(9CMaŭSKj9+]Iʷ?$3O)PNoO7}+5]ȽʹJ(bJ`CU(o rW]M@ZFT5(φ-<@a\^G~խ|vHWr!fk!~EIa@9p>,eS!L9 0Euxs9=x 쿥9Fe{nD+~xvGl7Z#$VSv-^&QgOϳW/&S@zƇ2fo~pbȿGsksX)ŚWKH'-Ͻt߮yg*:Yū'wS5o^=i9pxZgpxi\yjoxNW"/8jͻX-M)|-V(}[徙/O|.M}x?߬yZsLGy'~x|bɊ5.$m9|lOE}Rtf=_aGj>^ҫ\ W`D\@7MO?5^ߏ,.UI}x84݇߃}0;kU~m|Dk]f5gQ(}_gz'EuW4SL@ӉZ%d7JiP3Y& ر\fW~֟D6sľaM l /U|_$OpsGYyx7Q1G⧃'ğW`ŋSaPy,+=<7CHW3qgVu0H|S2?sk5xXx"G2RX-rn}+/'v1kģ~)ƎoDz.aBH1N7.J>e[,|٫ P=38$!]3Ϲo9?ft鞦<9xWo'&_^&d! "ƍԿx ]4 hR(r"x7Ղ=ު9m9/]GK5r?3q&JhqW)S:cxHuGI%)n`Q_jP=ROҗt6bG.~^xG1)y|9P_/_7K؟{\Gn)%!}vJW{n)q"={Y~I;o4T׋' ^6nE9MmF}Bo/K jJ_|y_OM|kh<~C7>,7uL,ȐtcS\Hfg*xl[}iNrv8%!ȯgįu+]%/*H|?Vp\圖X,]m7s5;_hv0#=Y!Ki_=xL=:PNk_J_`pڊh:Vn'p߽+>v鼷=ϊ"ČjM_i\({!]毉Ӭo[E7W[}aSׂɖKuyS{QIujSf}ؤT}[9C\z>ǯL!Kuws1 ŋ]T7 W׹Yy2}YqwWzp5>~ǖx B? 2g|?6qԩ[3ڱGYs:N`ΩHLyw]w k!F*N$WA&YSIS{V5ǻN&ľ$_g~E=+p4}sM~%ҁt[Ǚۄo+qB>T/ +.J^=J yt͝'`/9ֱVKFY /=N: q3O>Kb.(S~mZlIOVG k }:}; w;&[?4{~HJǦ{5vJBaGқշ)EݐVp ~u$?|&ϟ{Cq?uބKφ .]BW2r5gzΦ`斝'ku5uxF2dN78oQʾ]l%^u9G%0?ȍW+?Dp]}q?xaOiq_kf׽* K7{˖}No༘xIT 3&P1c+bH"s[ioE5-^9687གUVJ&..{}msPޝĻIϹb8'\ԽK| ^t?':-~6u4^3 Uܮx)v>Q]ʰi7Hأ9ޘ:>'*]icxu%rOי+o\x3Kaosow:cFex{<~ź!P޳Fc97orny&Hߧ[oa鼔t5R?mͥUW{茱;G o&~x53h]y+'R'ݢ:zQ }GSį|)=rK2Sz,{gпL=t4 tqbQN>i>8W:ӧ' /Sl-LClὬgVpUN!3o8b"z16ێf4擾Df/3}h^+ӗU<ЖNt {ymR!H^R \b{h x`Ik_{q5r9y ƒwv%..a8g.k<&+&@[=Ⱥ6ǝҁouƘފ}l08,5"E*Xg?;^0HW!$:T_O٣/lW˗#^ܯ+,Z_6*_7sz)Si`C% a?՜ ͗>|F_ޅ=(; ePt']{3.K)cۮgʤKzYVٙڗ+ݤsYarstim@xf⋧Ob9޾@ow9DcVj'ڭzWd]KZ:G)]sLUNC}AOs!txZGQ(P}cxV0:G wԱuɭ$>:{.-ԧWx<=)uouo>eE;K?yI=ěPƺ'/G`muO9Mh$xj#!\򜥜Ϳ}͍ۛo[.ᾺO>ͪF2:ߴ>ԭ\~פ}%%L<[YYI9\ION19Ϫe 䇀g7s=м!_MyHsdk4/ཝO M^+}gɻd;/WU=?w>qF$M?_v ՗£X~JO%Ih0ވ?wIw*tDC8?g MSsz9z>k NO=ip_`Gr 6ᗌLo:9z {]<:C _6qy rO]:խDz>/؏?K+^qh-$>_:ʽ-^I+voWBx#~COycx&9o ?>#R;җ76'maKg_l_Eػ?3~bGC5fQ$&v6}3 7@s}sOh½|}UsĿh^/y:[[<-^_,Xs ;{Wd쳨$\+[lW_؛+ݗK3g>U;B΋_j'ҏg=G>G>8;{ϹK';Kc{FqցC9B?-tyʟ މ0'o\7/#{^O|ڤRˤ/v'8JΣ™=ozY8C{j~sq{ Q{y=zI.z/4d~co_ov+)/XJCs u{2'gB?`gK?U.z[9zB/uG|b%b;^S}xkLjqIc+|NvGiϝ8[(;G݇OGi^vstb}X׌xSSCUT}QL;$/uK.kq6CV4:1-@vFpWSזjT`+;P=>Ho|G Gih,Du{J_">VzϲC6Y =,ރZ'T?pFKOnb@>܃Oe4տ߅{:z?Ky5u)qͽgnß(3%)G79O77_#>Ĩq>ͽ4_S}_W?߿=C;4ǡд&L;|CsQ⡺L|ꈇ/ZnJc)au+oyW!+d}hT\_~?u2[hb5ͭK5Mc3)oO?|Sz7b+5pNq<ϗG=#* H :Ey"{uXꂛ'xoWTo:eҩ03[ߕ3Vx prP}.ƵBb.ңH"m?}D_y0"~dgNi;;(]JU=O/`CεƯߌ};|qvmÞY?inx2!ޕmUG[ ?^zKWmz 5X  {՟Sm.?׫yܒ}D!gg];ܓvh;SG^îClԜXa9C:p1 ^e/y^ lE8WÏ 7'c4I. 3Gyz>b'˛ WJWZ𥵅8y ڰ~mwrv;khԏė|(? ZsOjW?HNo?SUo-qwMwh/ғwH? +ϫ~p{tY)]WYi|#24s ='_or^9cBa)lb?ou6#1Tܖis p5 ͙ekm6rަ_)|nW[4 N7G:mV=3 Y-=dXœ]5'cthösi?zk5({]|DU0 Jr4}4}OO[z[WkGf܅x4z4Uni9P}@5tUZ`*7KcT_Oz3m}W٧?b#$AͭV7VTK97;o]s_ ArK;]]-"k)Q^&GP CzVSK;[GJ/Tʟw`NC<.Q=,wsqz8YC,]Ϝwvzknɽp1349mNk?s/>9I; `ù A<=1C$n{@uGsxQ{m&.z]?{Zzv>ݿ-W>˖Q鸋u/{TsoM_b/Z^l; Kq^Tm[p͓=3{O}=Wln~ ӼNǞ[G{Һt`Sw~_޷IX_}D+>sF˿ ~ ;By$Sj`F~{JR"Q6mmQI^͌缇 ?s~ιsι{}\l54H$IIU&(?cH$]uB1iѡF6C̵zCyBRw$ԣbGWvCط+xqS?{2e׆?l(ʬCVY?aL BVE)Ūo#o]) ̨镚Y ¦NzH욶__ u6@ǓDHo@bVpN!7\Xo{$jd/hM-+_Y3I+A.P/A\U]n_-: ތ=LHt (oC&?$ ?tZ&KAH]a^c-勇 );r\<"~Ac vMXCl٘1:DkLZwd {HG/OXE끓7ZZNs.F˶֙FO!u:tnVt zM w%|}dzH_XxA523/ V┏&pҬILjy5 FTq֝W-D8K]s,= l-n^ET~ߦlXdJNgA8ud?p4%>ShzhnW;F0Imp3Mʏ)j.xwI;%Ot[P^|Gc2.Otvfd e?IU9J{SxsKuY6=AU^Su_ҳ~XTLK=hPWu/;;؂en(W/Q]d*Wq#^3D x{ԛIRz`5Ty&[ow>,'HH'=Mg qqh9b?- Wd@~o/'w 7ߦ~}sx.44OqJ33iQe?ׁU)r;4nY'j3ۭk]u;JКSf\HP=]h2T5 k "&Q,m"WFZBUϱ?A}W iV Ϟ\(,$RhQZtZCm2c>/9+;geFvu4Je^!* *{2[ٻX=h> =WzhG8_ku~Y#ύ&AĔ1{#1>v9rBsU:킪Up1m _Dar |Tނȗrc ^+i}ni`opL_e낓mq|bp^]S3JmJ)ֲ`}潂ըKDvASNi#kuxy tY:r/.Nfx ?}+4qsI\>$^Vʕ`||YW&Edg|lLylp͔B vWvwLIݹrrQ+,Wi)OR,T5(禎Y7y;v+xƙq9.#UQğ)#۵e|x|^S^2G`{ҽSYmr`t_uVPC}пr8E5:NPSջ Ʌ-R{T'F CI&؎A Pvc ,˝xLԖ?jD i%oWūIc=f=`z82Qs+mJ8c,gU>v!DNxCAfoec- z =| 8s ؂wW BmQ{bƆ=ptgl!Ф-TvB\B /9'1o/Sޘ|\*ffVZ`[7:Q{]}͢"!(q5^D_itm`qG 6'EwCMf 7ϢC\dѱLC?Ƒ] .{ֲp7HF3v.9OZtUo+^Yӱ|C3@9}h%VN_w l6CiWw}r[xj[oX὜[w|&oukA{aSw=h}a[SLZ g!T7W%Tp̾Zn NO|0ܻVoU+w޵cϡZ6Eigjks"djb]> 𳍒NXymM*#g@bH]u4*C !Ǥi>OUu]ѝJ!k{V2čZV=/u1B` ;O5kؖGV 39N}@'w6陎Rdbd^poHo'Hum=W 5Bdg5Qg2+i vG"ށ5 m2]Bn~*Gr-ڤwϋBB:4ڛ;"(ѱ%D_EpѢMWS#DۃAeGQy0"C A|QũILr9j#:١d:-aA0e!jZTI"Q})1Tp#umHF'H;t$R}2-2N5]dDQnZ8Ia2ijBBcLci#XWZf `љ.q8Ȉ9fR#3IAQL Zj seriation/data/Wood.rda0000644000176200001440000001553112606356654014602 0ustar liggesusers]y?1w}9}u{ȓH$ IL!QE*E|!$;Պ$t,}2&yf;0^<<}< `)0% 5J ǤgRW-M|9|.c#W/{Ups\ "kJ0%m/H;9&[gߤ/yv ܘ)C?]s{1H{P`krz6 ZRwvUV a4mQλ[#@Tۅ#NVlaJq8U*(1}эm ?7] +&TGu9?"и2w!1Jh"MQҹ`hQY3 =]zf,aM}VӶ:,d7Xʻ3ˀ~^=O K>)kWXZ{bMF<9UIiʗ>{Y4,;ޕhec sQ?/fЗdS6:c-N{ĉ Um?GY8$lAy/GOtAB^EOX˓vCzFHX{LQjUyfo<Džحπ+4 o9ԝzw?;%KoF܅1orvʺFxV/0pwc? w?Nƽ346<:Agj] xwI3@U4Yf˘*O;,I6Ma{- \gT!G>价eA-_ TN޴FnhK:ms.gE P,H] }J{@{ޕ0잳܄ƙNJ0h{4`9LC8xkovmTs10 [ f}]XST^ ;_t:n{,IX&AsPLZ_t|-7҄{=P˽eObS41Y#ߥҞO\z_٤{BLL?CE[ڪA띓{s`A}=U廵EIΠk+ŞEKʯwX'dEHH,m<%N !"yi~PrR}3)U܀%G]m|ǹQc:@1&*_Htcv~makH0 hHKMڼ7xR{509,"i TafLJ y-= 83z6^GUfd \p`7ԛ"A1c/K:7T`P]Uєj1{V6C:MQz8i} v*x݃]ɧSx~c74꘻;NfcmiGuH)GSa ԻH@ml,qCP/vz 1saX;tW>&l RZiQk4WꞺn݋e'}l~h2XzQ}ڣa@˻s$ETtIh%UrZWeOI5|L霥&["fmL,+Y'xvQŒя7`򻋛==0UiTT|n藗7^tk\TI#et1'mHXFm Jyo2 /nc@r;g}cc,C}Ӯ2yUu`^?dŇrbjC_jܾPjLJ/m։QаCTSxsЉJI U:`XfZ,ssU}(p;{5gb2+'`SZwϯ`M^SŹ+`]A>֏MiB}06!*NVئOO^io?(bG‰ؾoUtLֱ$sWלL2K|w@U-s[QK!aP- ؍͋A{} N o tOrkjCKEkbuzp1Y?|TǾ d8k^;0Iƚ(j^E5VZMdhz>tnk55ǽ Z}kƃ0h3Mnx5[WS d1wn;g4 '7wDe_0u_о:gn,e||Z3;%՞F/K\yl6ZNTgwT^z]3o]$n ف \a_:AeGMS1)"hEE/sLT\'}@F~zlF| Rtӆaf& B=^ACkJc) g^ \ZLJ@x2n/k {}gOT}o֘=_rYjs$vd9TWUrU0i/uמZ K]d#U)˯f"ʠ+xעSG|y]SVWY N9znO}"JDCBW#f:u3b+]-IܨP.`/C{rV&֊q֓;|#&+.OH\_Xw!'ў>fb[3xO- h36t߃W KF#C+#рx/jtu8Yԭ@]񀛫s"D 4-CU*Ps\cD?u?辜F! ^ᚑ ~->j5sj9}= kYKʅeCMt(! tr>$ /;dd95Ir(~9/^A)@?=zo7{C6Px/D9{˓6^0자U )wo.WE-^+t@kG@۫6XF~2-~!-cKe!Mg : I嵐oG{YP^|k3(~cUcQ3jvY+}a雧3j٢6]k|Dr^sFVl9 f>@@*;,f=f?wH| f7 !TVh|3]Dn|S_/m_J'3QF&hj9x$u"T=+dINY/sތ'}Amua囡ehLqNhD âs3sꑣtu>ztW9n6b-fg&n=/lBw"ՠ4Rf%XڵXEM% ğ.uDZI,_5 )_g"wf#2M(+).nxbzO 1ݎ?wԨ ^.\yF;b0IlkkvF}f)ʿC\B}`ݳ4Zv&X#~40mE,{> oӫ3mj05̢A`5g):3OME}=>= c<.O8h;]>;)YV#Aߞl46(>'>!EPSo6FoF1d" wi`ٿ֏64#aЎZ$peUI,5rl(_!U'M۪6Vr`j;+fīw[zr2ZthS=.,@gf#{Y3VxzEEqV_˘ aC|m~^yoȚ}ҧg) AbfkЋNۚ06}bwK 9 OIAݛv,腖E&)awO_20K? 5H 㲓7n,ԘѱT]Ln=ĉJcA2=ވ{* oDA}QbXZ7.5C=;iQyNXzKfģ?bVԆ8r D:Z@{jsF,5ٸfk,OƧ*P4fD[2=Ie$xr.#@v>(i1373 e(H`اɖS EOvM{g ٽUf@Kcͻ6dK@z+LUu_y-*|nFǿDu>"2OqWlC#sDŽahXͩߐ&Wn̄ǴCb0N`.+>طMdzG"K?sbR!X;ۜPz\_UwzPI >hBzAgL^IS8~PY ӛ8Χ!Yup/R!s9"469P/E{w˳ˣQe2mLd_)#󼹦| o5o*ԁLÆKyu'#;?~Q[l@Kɘ  sPE ]UP%m``#Tԕ.8S~P= 9%Ds'}L>C7+`*<$IMuP;wFX*PȌZXGjo!e/Ti-}+`k^NØ7Se|W䍢E엗.q4(<"L=?B_ O*~ٙCgYWHt'7w 5k6StB>2ٲRjj/'51!1χ >Y›j+5wKŖ{1Ӷ9ûVJs~L[]l-1o=3-V[goo\J;[|-;)~rgZȞo+6Kl9'!YJSJkbvm &e6|)}؝ZÚ&?Yf ۖ^NZl)ŎIwZZ[j&ۊՏs)W)>R|;{yk۾Rj?{-+Ͻ+K&w{3WwfnC~ܳ럕Ǐk)lˍ͏3 =8Ӝ=nfY|FL/t/;'fڢ6jYߵN/[%ݘNlǺ_q6f=sw3wߝf <`痾Sorv '|.o0ts1}n(W@}Zx9}"رa>+&CLu:Vhj4z\!e@"k+aDg/_>#seriation/data/Munsingen.rda0000644000176200001440000000117012606356654015627 0ustar liggesusersOk0a oO0Oem&Ã^d_,C钴@ |7i@_r !jQ+Q\8G%|Γi]"4?WwB[/A)?)%{m*狊G7J>M)zʉCEi}.XZpcN^RHJy虓W3ߐ(Eʵ'EQ}k[r]c*9@e}ܜk*8<]2W.M=WjJ%E^/~sb%mq$CԵ۵ݷrReZm:U[Crݗ{ھ%GnQrshjMu9\k18&N} n^9AI\kGrtziG?rjA.8kS(u嗒o.rS禸Z/*4]B}}\preformatted{Sirovich, L. (2003). A pattern analysis of the second Rehnquist U.S. Supreme Court. _Proceedings of the National Academy of Sciences of the United States of America,_ **100**, 7432-7437. \doi{10.1073/pnas.1132164100} }\if{html}{\out{}} } \seealso{ Other data: \code{\link{Chameleon}}, \code{\link{Irish}}, \code{\link{Munsingen}}, \code{\link{Townships}}, \code{\link{Wood}}, \code{\link{Zoo}}, \code{\link{create_lines_data}()}, \code{\link{is.robinson}()} } \author{ Michael Hahsler } \concept{data} \keyword{datasets} seriation/man/criterion.Rd0000644000176200001440000003436414607755377015346 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/criterion.R, R/criterion.array.R, % R/criterion.dist.R, R/criterion.matrix.R \name{criterion} \alias{criterion} \alias{criterion.array} \alias{criterion.dist} \alias{criterion.matrix} \alias{criterion.data.frame} \alias{criterion.table} \title{Criterion for a Loss/Merit Function for Data Given a Permutation} \usage{ criterion(x, order = NULL, method = NULL, force_loss = FALSE, ...) \method{criterion}{array}(x, order = NULL, method = NULL, force_loss = FALSE, ...) \method{criterion}{dist}(x, order = NULL, method = NULL, force_loss = FALSE, ...) \method{criterion}{matrix}(x, order = NULL, method = NULL, force_loss = FALSE, ...) \method{criterion}{data.frame}(x, order = NULL, method = NULL, force_loss = FALSE, ...) \method{criterion}{table}(x, order = NULL, method = NULL, force_loss = FALSE, ...) } \arguments{ \item{x}{an object of class \link{dist} or a matrix (currently no functions are implemented for array).} \item{order}{an object of class \link{ser_permutation} suitable for \code{x}. If \code{NULL}, the identity permutation is used.} \item{method}{a character vector with the names of the criteria to be employed (see \code{\link[=list_criterion_methods]{list_criterion_methods()}}), or \code{NULL} (default) in which case all available criteria are used.} \item{force_loss}{logical; should merit function be converted into loss functions by multiplying with -1?} \item{...}{additional parameters passed on to the criterion method.} } \value{ A named vector of real values. } \description{ Compute the value for different loss functions \eqn{L} and merit function \eqn{M} for data given a permutation. } \details{ \strong{Criteria for distance matrices (dist)} For a symmetric dissimilarity matrix \eqn{D} with elements \eqn{d(i,j)} where \eqn{i, j = 1 \ldots n}, the aim is generally to place low distance values close to the diagonal. The following criteria to judge the quality of a certain permutation of the objects in a dissimilarity matrix are currently implemented (for a more detailed description and an experimental comparison see Hahsler (2017)): \itemize{ \item \strong{Gradient measures:} \code{"Gradient_raw"}, \code{"Gradient_weighted"} (Hubert et al, 2001) A symmetric dissimilarity matrix where the values in all rows and columns only increase when moving away from the main diagonal is called a perfect \emph{anti-Robinson matrix} (Robinson 1951). A suitable merit measure which quantifies the divergence of a matrix from the anti-Robinson form is \deqn{ M(D) = \sum_{i=1}^n \sum_{i y.} It results in raw number of triples satisfying the gradient constraints minus triples which violate the constraints. The second function is defined as: \deqn{f(z,y) = |y-z| sign(y-z) = y-z} It weights the each satisfaction or violation by the difference by its magnitude given by the absolute difference between the values. \item \strong{Anti-Robinson events:} \code{"AR_events"}, \code{"AR_deviations"} (Chen, 2002) \code{"AR_events"} counts the number of violations of the anti-Robinson form. \deqn{ L(D) = \sum_{i=1}^n \sum_{i d_{ik}) } where \eqn{m=(2/3-n)w + nw^2 - 2/3 w^3}, the maximal number of possible anti-Robinson events in the window. The window size \eqn{w} represents the number of neighboring objects (number of entries from the diagonal of the distance matrix) are considered. The window size is \eqn{2 \le w < n}, where smaller values result in focusing on the local structure while larger values look at the global structure. \code{...} parameters are: \itemize{ \item \code{w} window size. Default is to use a \code{pct} of 100\% of \eqn{n}. \item \code{pct} and alternative specification of w as a percentage of \eqn{n} in \eqn{(0, 100]}. \item \code{relative} logical; can be set to \code{FALSE} to get the GAR, i.e., the absolute number of AR events in the window. } \item \strong{Banded anti-Robinson form criterion:} \code{"BAR"} (Earle and Hurley, 2015) Simplified measure for closeness to the anti-Robinson form in a band of size \eqn{b} with \eqn{1 <= b < n} around the diagonal. \deqn{ L(D) = \sum_{|i-j|<=b} (b+1-|i-j|) d_{ij} } For \eqn{b = 1} the measure reduces to the Hamiltonian path length. For \eqn{b = n-1} the measure is equivalent to ARc defined (Earle and Hurley, 2015). Note that ARc is equivalent to the Linear Seriation criterion (scaled by 1/2). \code{...} parameter is: \code{b} band size defaults to a band of 20\% of \eqn{n}. \item \strong{Hamiltonian path length:} \code{"Path_length"} (Caraux and Pinloche, 2005) The order of the objects in a dissimilarity matrix corresponds to a path through a graph where each node represents an object and is visited exactly once, i.e., a Hamilton path. The length of the path is defined as the sum of the edge weights, i.e., dissimilarities. \deqn{L(D) = \sum_{i=1}^{n-1} d_{i,i+1}} The length of the Hamiltonian path is equal to the value of the minimal span loss function (as used by Chen 2002). Both notions are related to the \emph{traveling salesperson problem (TSP).} If \code{order} is not unique or there are non-finite distance values \code{NA} is returned. \item \strong{Lazy path length:} \code{"Lazy_path_length"} (Earl and Hurley, 2015) A weighted version of the Hamiltonian path criterion. This loss function postpones larger distances to later in the order (i.e., a lazy traveling sales person). \deqn{L(D) = \sum_{i=1}^{n-1} (n-i) d_{i,i+1}} Earl and Hurley (2015) proposed this criterion for reordering in visualizations to concentrate on closer objects first. \item \strong{Inertia criterion:} \code{"Inertia"} (Caraux and Pinloche, 2005) Measures the moment of the inertia of dissimilarity values around the diagonal as \deqn{M(D) = \sum_{i=1}^n \sum_{j=1}^n d(i,j)|i-j|^2} \eqn{|i-j|} is used as a measure for the distance to the diagonal and \eqn{d(i,j)} gives the weight. This criterion gives higher weight to values farther away from the diagonal. It increases with quality. \item \strong{Least squares criterion:} \code{"Least_squares"} (Caraux and Pinloche, 2005) The sum of squared differences between distances and the rank differences: \deqn{L(D) = \sum_{i=1}^n \sum_{j=1}^n (d(i,j) - |i-j|)^2,} where \eqn{d(i,j)} is an element of the dissimilarity matrix \eqn{D} and \eqn{|i-j|} is the rank difference between the objects. Note that if Euclidean distance is used to calculate \eqn{D} from a data matrix \eqn{X}, the order of the elements in \eqn{X} by projecting them on the first principal component of \eqn{X} minimizes this criterion. The least squares criterion is related to \emph{unidimensional scaling.} \item \strong{Linear Seriation Criterion:} \code{"LS"} (Hubert and Schultz, 1976) Weights the distances with the absolute rank differences. \deqn{L(D) \sum_{i,j=1}^n d(i,j) (-|i-j|)} \item \strong{2-Sum Criterion:} \code{"2SUM"} (Barnard, Pothen and Simon, 1993) The 2-Sum loss criterion multiplies the similarity between objects with the squared rank differences. \deqn{L(D) \sum_{i,j=1}^n 1/(1+d(i,j)) (i-j)^2,} where \eqn{s(i,j) = 1/(1+d(i,j))} represents the similarity between objects \eqn{i} and \eqn{j}. \item \strong{Absolute Spearman Correlation} \code{"Rho"} The absolute value of the Spearman rank correlation between the original distances and the rank differences in the order. \item \strong{Matrix measures:} \code{"ME"}, \code{"Moore_stress"}, \code{"Neumann_stress"} These criteria are defined on general matrices (see below for definitions). The dissimilarity matrix is first converted into a similarity matrix using \eqn{S = 1/(1+D)}. If a different transformation is required, then perform the transformation first and supply a matrix instead of a dist object. } \strong{Criteria for matrices (matrix)} For a general matrix \eqn{X = x_{ij}}, \eqn{i = 1 \ldots n} and \eqn{j = 1 \ldots m}, currently the following loss/merit functions are implemented: \itemize{ \item \strong{Measure of Effectiveness:} \code{"ME"} (McCormick, 1972). The measure of effectiveness (ME) for matrix \eqn{X}, is defined as \deqn{M(X) = 1/2 \sum_{i=1}^{n} \sum_{j=1}^{m} x_{i,j}(x_{i,j-1}+x_{i,j+1}+x_{i-1,j}+x_{i+1,j})} with, by convention \deqn{x_{0,j}=x_{m+1,j}=x_{i,0}=x_{i,n+1}=0.} ME is a merit measure, i.e. a higher ME indicates a better arrangement. Maximizing ME is the objective of the bond energy algorithm (BEA). ME is not defined for matrices with negative values. \code{NA} is returned in this case. \item \strong{Weighted correlation coefficient:} \code{"Cor_R"} (Deutsch and Martin, 1971) Developed as the Measure of Effectiveness for the Moment Ordering Algorithm. R is a merit measure normalized so that its value always lies in \eqn{[-1,1]}. For the special case of a square matrix \eqn{R=1} corresponds to only the main diagonal being filled, \eqn{R=0} to a random distribution of value throughout the array, and \eqn{R=-1} to the opposite diagonal only being filled. \item \strong{Matrix Stress:} \code{"Moore_stress"}, \code{"Neumann_stress"} (Niermann, 2005) Stress measures the conciseness of the presentation of a matrix/table and can be seen as a purity function which compares the values in a matrix/table with its neighbors. The stress measure used here is computed as the sum of squared distances of each matrix entry from its adjacent entries. \deqn{ L(X) = \sum_{i=1}^n \sum_{j=1}^m \sigma_{ij} } The following types of neighborhoods are available: \itemize{ \item Moore: comprises the eight adjacent entries. \deqn{ \sigma_{ij} = \sum_{k=\max(1,i-1)}^{\min(n,i+1)} \sum_{l=\max(1,j-1)}^{\min(m,j+1)} (x_{ij} - x_{kl})^2 } \item Neumann: comprises the four adjacent entries. \deqn{ \sigma_{ij} = \sum_{k=\max(1,i-1)}^{\min(n,i+1)} (x_{ij} - x_{kj})^2 + \sum_{l=\max(1,j-1)}^{\min(m,j+1)} (x_{ij} - x_{il})^2 } } The major difference between the Moore and the Neumann neighborhood is that for the later the contribution of row and column permutations to stress are independent and thus can be optimized independently. } } \examples{ ## create random data and calculate distances m <- matrix(runif(20),ncol=2) d <- dist(m) ## get an order for rows (optimal for the least squares criterion) o <- seriate(d, method = "MDS") o ## compare the values for all available criteria rbind( unordered = criterion(d), ordered = criterion(d, o) ) ## compare RGAR by window size (from local to global) w <- 2:(nrow(m)-1) RGAR <- sapply(w, FUN = function (w) criterion(d, o, method="RGAR", w = w)) plot(w, RGAR, type = "b", ylim = c(0,1), xlab = "Windows size (w)", main = "RGAR by window size") } \references{ Barnard, S.T., A. Pothen, and H. D. Simon (1993): A Spectral Algorithm for Envelope Reduction of Sparse Matrices. \emph{In Proceedings of the 1993 ACM/IEEE Conference on Supercomputing,} 493--502. Supercomputing '93. New York, NY, USA: ACM. Caraux, G. and S. Pinloche (2005): Permutmatrix: A Graphical Environment to Arrange Gene Expression Profiles in Optimal Linear Order, \emph{Bioinformatics,} \strong{21}(7), 1280--1281. Chen, C.-H. (2002): Generalized association plots: Information visualization via iteratively generated correlation matrices, \emph{Statistica Sinica,} \strong{12}(1), 7--29. Deutsch, S.B. and J.J. Martin (1971): An ordering algorithm for analysis of data arrays. \emph{Operational Research,} \strong{19}(6), 1350--1362. \doi{10.1287/opre.19.6.1350} Earle, D. and C.B. Hurley (2015): Advances in Dendrogram Seriation for Application to Visualization. \emph{Journal of Computational and Graphical Statistics,} \strong{24}(1), 1--25. \doi{10.1080/10618600.2013.874295} Hahsler, M. (2017): An experimental comparison of seriation methods for one-mode two-way data. \emph{European Journal of Operational Research,} \strong{257}, 133--143. \doi{10.1016/j.ejor.2016.08.066} Hubert, L. and J. Schultz (1976): Quadratic Assignment as a General Data Analysis Strategy. \emph{British Journal of Mathematical and Statistical Psychology,} \strong{29}(2). Blackwell Publishing Ltd. 190--241. \doi{10.1111/j.2044-8317.1976.tb00714.x} Hubert, L., P. Arabie, and J. Meulman (2001): \emph{Combinatorial Data Analysis: Optimization by Dynamic Programming.} Society for Industrial Mathematics. \doi{10.1137/1.9780898718553} Niermann, S. (2005): Optimizing the Ordering of Tables With Evolutionary Computation, \emph{The American Statistician,} \strong{59}(1), 41--46. \doi{10.1198/000313005X22770} McCormick, W.T., P.J. Schweitzer and T.W. White (1972): Problem decomposition and data reorganization by a clustering technique, \emph{Operations Research,} \strong{20}(5), 993-1009. \doi{10.1287/opre.20.5.993} Robinson, W.S. (1951): A method for chronologically ordering archaeological deposits, \emph{American Antiquity,} \strong{16}, 293--301. \doi{10.2307/276978} Tien, Y-J., Yun-Shien Lee, Han-Ming Wu and Chun-Houh Chen (2008): Methods for simultaneously identifying coherent local clusters with smooth global patterns in gene expression profiles, \emph{BMC Bioinformatics,} \strong{9}(155), 1--16. \doi{10.1186/1471-2105-9-155} } \seealso{ Other criterion: \code{\link{registry_for_criterion_methods}} } \author{ Michael Hahsler } \concept{criterion} \keyword{cluster} seriation/man/ser_dist.Rd0000644000176200001440000001430414607606260015136 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ser_dist.R \name{ser_dist} \alias{ser_dist} \alias{ser_cor} \alias{ser_align} \title{Dissimilarities and Correlations Between Seriation Orders} \usage{ ser_dist(x, y = NULL, method = "spearman", reverse = TRUE, ...) ser_cor(x, y = NULL, method = "spearman", reverse = TRUE, test = FALSE) ser_align(x, method = "spearman") } \arguments{ \item{x}{set of seriation orders as a list with elements which can be coerced into \link{ser_permutation_vector} objects.} \item{y}{if not \code{NULL} then a single seriation order can be specified. In this case \code{x} has to be a single seriation order and not a list.} \item{method}{a character string with the name of the used measure. Available measures are: \code{"kendall"}, \code{"spearman"}, \code{"manhattan"}, \code{"euclidean"}, \code{"hamming"}, \code{"ppc"} (positional proximity coefficient), and \code{"aprd"} (absolute pairwise rank differences).} \item{reverse}{a logical indicating if the orders should also be checked in reverse order and the best value (highest correlation, lowest distance) is reported. This only affect ranking-based measures and not precedence invariant measures (e.g., \code{"ppc"}, \code{"aprd"}).} \item{...}{Further arguments passed on to the method.} \item{test}{a logical indicating if a correlation test should be performed.} } \value{ \itemize{ \item \code{ser_dist()} returns an object of class \link[stats:dist]{stats::dist}. \item \code{ser_align()} returns a new list with elements of class \link{ser_permutation}. } } \description{ Calculates dissimilarities/correlations between seriation orders in a list of type \link{ser_permutation_vector}. } \details{ \code{ser_cor()} calculates the correlation between two sequences (orders). Note that a seriation order and its reverse are identical and purely an artifact due to the method that creates the order. This is a major difference to rankings. For ranking-based correlation measures (Spearman and Kendall) the absolute value of the correlation is returned for \code{reverse = TRUE} (in effect returning the correlation for the reversed order). If \code{test = TRUE} then the appropriate test for association is performed and a matrix with p-values is returned as the attribute \code{"p-value"}. Note that no correction for multiple testing is performed. For \code{ser_dist()}, the correlation coefficients (Kendall's tau and Spearman's rho) are converted into a dissimilarity by taking one minus the correlation value. Note that Manhattan distance between the ranks in a linear order is equivalent to Spearman's footrule metric (Diaconis 1988). \code{reverse = TRUE} returns the pairwise minima using also reversed orders. The positional proximity coefficient (ppc) is a precedence invariant measure based on product of the squared positional distances in two permutations defined as (see Goulermas et al 2016): \deqn{d_{ppc}(R, S) = 1/h \sum_{j=2}^n \sum_{i=1}^{j-1} (\pi_R(i)-\pi_R(j))^2 * (\pi_S(i)-\pi_S(j))^2,} where \eqn{R} and \eqn{S} are two seriation orders, \eqn{pi_R} and \eqn{pi_S} are the associated permutation vectors and \eqn{h} is a normalization factor. The associated generalized correlation coefficient is defined as \eqn{1-d_{ppc}}. For this precedence invariant measure \code{reverse} is ignored. The absolute pairwise rank difference (aprd) is also precedence invariant and defined as a distance measure: \deqn{d_{aprd}(R, S) = \sum_{j=2}^n \sum_{i=1}^{j-1} | |\pi_R(i)-\pi_R(j)| - |\pi_S(i)-\pi_S(j)| |^p,} where \eqn{p} is the power which can be passed on as parameter \code{p} and is by default set to 2. For this precedence invariant measure \code{reverse} is ignored. \code{ser_align()} tries to normalize the direction in a list of seriations such that ranking-based methods can be used. We add for each permutation also the reversed order to the set and then use a modified version of Prim's algorithm for finding a minimum spanning tree (MST) to choose if the original seriation order or its reverse should be used. We use the orders first added to the MST. Every time an order is added, its reverse is removed from the possible remaining orders. } \examples{ set.seed(1234) ## seriate dist of 50 flowers from the iris data set data("iris") x <- as.matrix(iris[-5]) x <- x[sample(1:nrow(x), 50), ] rownames(x) <- 1:50 d <- dist(x) ## Create a list of different seriations methods <- c("HC_complete", "OLO", "GW", "VAT", "TSP", "Spectral", "MDS", "Identity", "Random") os <- sapply(methods, function(m) { cat("Doing", m, "... ") tm <- system.time(o <- seriate(d, method = m)) cat("took", tm[3],"s.\n") o }) ## Compare the methods using distances. Default is based on ## Spearman's rank correlation coefficient where reverse orders are ## also considered. ds <- ser_dist(os) hmap(ds, margin = c(7,7)) ## Compare using correlation between orders. Reversed orders have ## negative correlation! cs <- ser_cor(os, reverse = FALSE) hmap(cs, margin = c(7,7)) ## Compare orders by allowing orders to be reversed. ## Now all but random and identity are highly positive correlated cs2 <- ser_cor(os, reverse = TRUE) hmap(cs2, margin=c(7,7)) ## A better approach is to align the direction of the orders first ## and then calculate correlation. os_aligned <- ser_align(os) cs3 <- ser_cor(os_aligned, reverse = FALSE) hmap(cs3, margin = c(7,7)) ## Compare the orders using clustering. We use Spearman's foot rule ## (Manhattan distance of ranks). In order to use rank-based method, ## we align the direction of the orders. os_aligned <- ser_align(os) ds <- ser_dist(os_aligned, method = "manhattan") plot(hclust(ds)) } \references{ P. Diaconis (1988): \emph{Group Representations in Probability and Statistics,} Institute of Mathematical Statistics, Hayward, CA. J.Y. Goulermas, A. Kostopoulos, and T. Mu (2016): A New Measure for Analyzing and Fusing Sequences of Objects. \emph{IEEE Transactions on Pattern Analysis and Machine Intelligence} \strong{38}(5):833-48. \doi{10.1109/TPAMI.2015.2470671} } \seealso{ Other permutation: \code{\link{get_order}()}, \code{\link{permutation_vector2matrix}()}, \code{\link{permute}()}, \code{\link{ser_permutation}()}, \code{\link{ser_permutation_vector}()} } \author{ Michael Hahsler } \concept{permutation} \keyword{cluster} seriation/man/LS.Rd0000644000176200001440000000166614453321037013642 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/seriate_GSA.R \name{LS} \alias{LS} \alias{LS_swap} \alias{LS_insert} \alias{LS_reverse} \alias{LS_mixed} \title{Neighborhood functions for Seriation Method SA} \usage{ LS_swap(o, pos = sample.int(length(o), 2)) LS_insert(o, pos = sample.int(length(o), 2)) LS_reverse(o, pos = sample.int(length(o), 2)) LS_mixed(o, pos = sample.int(length(o), 2)) } \arguments{ \item{o}{an integer vector with the order} \item{pos}{random positions used for the local move.} } \value{ returns the new order vector representing the random neighbor. } \description{ Definition of different local neighborhood functions for the method \code{"SA"} for \code{\link[=seriate]{seriate()}}. } \details{ Local neighborhood functions are \code{LS_insert}, \code{LS_swap}, \code{LS_reverse}, and \code{LS_mix} (1/3 insertion, 1/3 swap and 1/3 reverse). Any neighborhood function can be defined. } seriation/man/register_tsne.Rd0000644000176200001440000000506214607573454016210 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/register_tsne.R \name{register_tsne} \alias{register_tsne} \alias{tsne} \alias{tSNE} \title{Register Seriation Based on 1D t-SNE} \usage{ register_tsne() } \value{ Nothing. } \description{ Use t-distributed stochastic neighbor embedding (t-SNE) for \code{\link[=seriate]{seriate()}}. } \details{ Registers the method \code{"tsne"} for \code{\link[=seriate]{seriate()}}. This method applies 1D t-SNE to a data matrix or a distance matrix and extracts the order from the 1D embedding. To speed up the process, an initial embedding is created using 1D multi-dimensional scaling (MDS) or principal comonents analysis (PCA) which is improved by t-SNE. The \code{control} parameter \code{"mds"} or \code{"pca"} controls if MDS (for distances) or PCA (for data matrices) is used to create an initial embedding. See \code{\link[Rtsne:Rtsne]{Rtsne::Rtsne()}} to learn about the other available \code{control} parameters. Perplexity is automatically set as the minimum between 30 and the number of observations. It can be also specified using the control parameter \code{"preplexity"}. \strong{Note:} Package \pkg{Rtsne} needs to be installed. } \examples{ \dontrun{ register_tsne() # distances get_seriation_method("dist", "tsne") data(SupremeCourt) d <- as.dist(SupremeCourt) o <- seriate(d, method = "tsne", verbose = TRUE) pimage(d, o) # look at the returned configuration and plot it attr(o[[1]], "configuration") plot_config(o) # the t-SNE results are also available as an attribute (see ? Rtsne::Rtsne) attr(o[[1]], "model") ## matrix get_seriation_method("matrix", "tsne") data("Zoo") x <- Zoo x[,"legs"] <- (x[,"legs"] > 0) # t-SNE does not allow duplicates x <- x[!duplicated(x), , drop = FALSE] class <- x$class label <- rownames(x) x <- as.matrix(x[,-17]) o <- seriate(x, method = "tsne", eta = 10, verbose = TRUE) pimage(x, o, prop = FALSE, row_labels = TRUE, col_labels = TRUE) # look at the row embedding plot_config(o[[1]], col = class) } } \references{ van der Maaten, L.J.P. & Hinton, G.E., 2008. Visualizing High-Dimensional Data Using t-SNE. \emph{Journal of Machine Learning Research,} \strong{9}, pp.2579-2605. } \seealso{ \code{\link[Rtsne:Rtsne]{Rtsne::Rtsne()}} Other seriation: \code{\link{register_DendSer}()}, \code{\link{register_GA}()}, \code{\link{register_optics}()}, \code{\link{register_smacof}()}, \code{\link{register_umap}()}, \code{\link{registry_for_seriaiton_methods}}, \code{\link{seriate}()}, \code{\link{seriate_best}()} } \concept{seriation} \keyword{cluster} \keyword{optimize} seriation/man/hmap.Rd0000644000176200001440000001572514456263135014261 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/hmap.R, R/gghmap.R \name{hmap} \alias{hmap} \alias{gghmap} \title{Plot Heat Map Reordered Using Seriation} \usage{ hmap( x, distfun = stats::dist, method = "OLO_complete", control = NULL, scale = c("none", "row", "column"), plot_margins = "auto", col = NULL, col_dist = grays(power = 2), row_labels = NULL, col_labels = NULL, ... ) gghmap( x, distfun = stats::dist, method = "OLO", control = NULL, scale = c("none", "row", "column"), prop = FALSE, ... ) } \arguments{ \item{x}{a matrix or a dissimilarity matrix of class dist. If a dissimilarity matrix is used, then the \code{distfun} is ignored.} \item{distfun}{function used to compute the distance (dissimilarity) between both rows and columns. For \code{gghmap()}, this parameter is passed on in \code{control}.} \item{method}{a character strings indicating the used seriation algorithm (see \code{\link[=seriate.dist]{seriate.dist()}}). If the method results in a dendrogram then \code{\link[stats:heatmap]{stats::heatmap()}} is used to show the dendrograms, otherwise reordered distance matrices are shown instead.} \item{control}{a list of control options passed on to the seriation algorithm specified in \code{method}.} \item{scale}{character indicating if the values should be centered and scaled in either the row direction or the column direction, or none. Default is none.} \item{plot_margins}{character indicating what to show in the margins. Options are: \code{"auto"}, \code{"dendrogram"}, \code{"distances"}, or \code{"none"}.} \item{col}{a list of colors used.} \item{col_dist}{colors used for displaying distances.} \item{row_labels, col_labels}{a logical indicating if row and column labels in \code{x} should be displayed. If \code{NULL} then labels are displayed if the \code{x} contains the appropriate dimname and the number of labels is 25 or less. A character vector of the appropriate length with labels can also be supplied.} \item{\dots}{further arguments passed on to \code{\link[stats:heatmap]{stats::heatmap()}}.} \item{prop}{logical; change the aspect ratio so cells in the image have a equal width and height.} } \value{ An invisible list with elements: \item{rowInd, colInd}{index permutation vectors.} \item{reorder_method}{name of the method used to reorder the matrix.} The list may contain additional elements (dendrograms, colors, etc). } \description{ Provides heatmaps reordered using several different seriation methods. This includes dendrogram based reordering with optimal leaf order and matrix seriation-based heat maps. } \details{ For dendrogram based heat maps, the arguments are passed on to \code{\link[stats:heatmap]{stats::heatmap()}} in \pkg{stats}. The following arguments for \code{heatmap()} cannot be used: \code{margins}, \code{Rowv}, \code{Colv}, \code{hclustfun}, \code{reorderfun}. For seriation-based heat maps further arguments include: \itemize{ \item \code{gp} an object of class \code{gpar} containing graphical parameters (see \code{\link[=gpar]{gpar()}} in package \pkg{grid}). \item \code{newpage} a logical indicating whether to start plot on a new page \item \code{prop} a logical indicating whether the height and width of \code{x} should be plotted proportional to its dimensions. \item \code{showdist} Display seriated dissimilarity matrices? Values are \code{"none"}, \code{"both"}, \code{"rows"} or \code{"columns"}. \item \code{key} logical; show a colorkey? \item \code{key.lab} Label plotted next to the color key. \item \code{margins} bottom and right-hand-side margins are calculated automatically or can be specifies as a vector of two numbers (in lines). \item \code{zlim} range of values displayed. \item \code{col}, \code{col_dist} color palettes used. } } \examples{ data("Wood") # regular heatmap from package stats heatmap(Wood, main = "Wood (standard heatmap)") # Default heatmap does Euclidean distance, hierarchical clustering with # complete-link and optimal leaf ordering. Note that the rows are # ordered top-down in the seriation order (stats::heatmap orders in reverse) hmap(Wood, main = "Wood (opt. leaf ordering)") hmap(Wood, plot_margins = "distances", main = "Wood (opt. leaf ordering)") hmap(Wood, plot_margins = "none", main = "Wood (opt. leaf ordering)") # Heatmap with correlation-based distance, green-red color (greenred is # predefined) and optimal leaf ordering and no row label dist_cor <- function(x) as.dist(sqrt(1 - cor(t(x)))) hmap(Wood, distfun = dist_cor, col = greenred(100), main = "Wood (reorded by corr. between obs.)") # Heatmap with order based on the angle in two-dimensional MDS space. hmap(Wood, method = "MDS_angle", col = greenred(100), row_labels = FALSE, main = "Wood (reorderd using ange in MDS space)") # Heatmap for distances d <- dist(Wood) hmap(d, main = "Wood (Euclidean distances)") # order-based with dissimilarity matrices hmap(Wood, method = "MDS_angle", col = greenred(100), col_dist = greens(100, power = 2), keylab = "norm. Expression", main = "Wood (reorderd with distances)") # without the distance matrices hmap(Wood, method = "MDS_angle", plot_margins = "none", col = greenred(100), main = "Wood (reorderd without distances)") # Manually create a simple heatmap with pimage. o <- seriate(Wood, method = "heatmap", control = list(dist_fun = dist, seriation_method = "OLO_ward")) o pimage(Wood, o) # Note: method heatmap calculates reorderd hclust objects which can be used # for many heatmap implementations like the standard implementation in # package stats. heatmap(Wood, Rowv = as.dendrogram(o[[1]]), Colv = as.dendrogram(o[[2]])) # ggplot 2 version does not support dendrograms in the margin (for now) if (require("ggplot2")) { library("ggplot2") gghmap(Wood) + labs(title = "Wood", subtitle = "Optimal leaf ordering") # More parameters (see ? ggpimage): reverse column order and flip axes, make a proportional plot gghmap(Wood, reverse_columns = TRUE) + labs(title = "Wood", subtitle = "Optimal leaf ordering") gghmap(Wood, flip_axes = TRUE) + labs(title = "Wood", subtitle = "Optimal leaf ordering") gghmap(Wood, flip_axes = TRUE, prop = TRUE) + labs(title = "Wood", subtitle = "Optimal leaf ordering") dist_cor <- function(x) as.dist(sqrt(1 - cor(t(x)))) gghmap(Wood, distfun = dist_cor) + labs(title = "Wood", subtitle = "Reorded by correlation between observations") + scale_fill_gradient2(low = "darkgreen", high = "red") gghmap(d, prop = TRUE) + labs(title = "Wood", subtitle = "Euclidean distances, reordered") # Note: the ggplot2-based version currently cannot show distance matrices # in the same plot. # Manually seriate and plot as pimage. o <- seriate(Wood, method = "heatmap", control = list(dist_fun = dist, seriation_method = "OLO_ward")) o ggpimage(Wood, o) } } \seealso{ Other plots: \code{\link{VAT}()}, \code{\link{bertinplot}()}, \code{\link{dissplot}()}, \code{\link{palette}()}, \code{\link{pimage}()} } \author{ Michael Hahsler } \concept{plots} \keyword{hplot} seriation/man/dissplot.Rd0000644000176200001440000003067214455551050015166 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dissplot.R, R/ggdissplot.R \name{dissplot} \alias{dissplot} \alias{plot.reordered_cluster_dissimilarity_matrix} \alias{print.reordered_cluster_dissimilarity_matrix} \alias{ggdissplot} \title{Dissimilarity Plot} \usage{ dissplot( x, labels = NULL, method = "spectral", control = NULL, lower_tri = TRUE, upper_tri = "average", diag = TRUE, cluster_labels = TRUE, cluster_lines = TRUE, reverse_columns = FALSE, options = NULL, ... ) \method{plot}{reordered_cluster_dissimilarity_matrix}( x, lower_tri = TRUE, upper_tri = "average", diag = TRUE, options = NULL, ... ) \method{print}{reordered_cluster_dissimilarity_matrix}(x, ...) ggdissplot( x, labels = NULL, method = "spectral", control = NULL, lower_tri = TRUE, upper_tri = "average", diag = TRUE, cluster_labels = TRUE, cluster_lines = TRUE, reverse_columns = FALSE, ... ) } \arguments{ \item{x}{an object of class \link{dist}.} \item{labels}{\code{NULL} or an integer vector of the same length as rows/columns in \code{x} indicating the cluster membership for each object in \code{x} as consecutive integers starting with one. The labels are used to reorder the matrix.} \item{method}{A single character string indicating the seriation method used to reorder the clusters (inter cluster seriation) as well as the objects within each cluster (intra cluster seriation). If different algorithms for inter and intra cluster seriation are required, \code{method} can be a \code{list} of two named elements (\code{inter_cluster} and \code{intra_cluster} each containing the name of the respective seriation method. Use \code{\link[=list_seriation_methods]{list_seriation_methods()}} with \code{kind = "dist"} to find available algorithms. Set method to \code{NA} to plot the matrix as is (no or, if cluster labels are supplied, only coarse seriation). For intra cluster reordering with the special method \code{"silhouette width"} is available (for \code{dissplot()} only). Objects in clusters are then ordered by silhouette width (from silhouette plots). If no \code{method} is given, the default method of \code{\link[=seriate.dist]{seriate.dist()}} is used. A third list element (named \code{aggregation}) can be added to control how inter cluster dissimilarities are computed from from the given dissimilarity matrix. The choices are \code{"avg"} (average pairwise dissimilarities; average-link), \code{"min"} (minimal pairwise dissimilarities; single-link), \code{"max"} (maximal pairwise dissimilarities; complete-link), and \code{"Hausdorff"} (pairs up each point from one cluster with the most similar point from the other cluster and then uses the largest dissimilarity of paired up points).} \item{control}{a list of control options passed on to the seriation algorithm. In case of two different seriation algorithms, \code{control} can contain a list of two named elements (\code{inter_cluster} and \code{intra_cluster}) containing each a list with the control options for the respective algorithm.} \item{upper_tri, lower_tri, diag}{a logical indicating whether to show the upper triangle, the lower triangle or the diagonal of the distance matrix. The string "average" can also be used to display within and between cluster averages in the two triangles.} \item{cluster_labels}{a logical indicating whether to display cluster labels in the plot.} \item{cluster_lines}{a logical indicating whether to draw lines to separate clusters.} \item{reverse_columns}{a logical indicating if the clusters are displayed on the diagonal from north-west to south-east (\code{FALSE}; default) or from north-east to south-west (\code{TRUE}).} \item{options}{a list with options for plotting the matrix (\code{dissplot} only). \itemize{ \item \code{plot} a logical indicating if a plot should be produced. if \code{FALSE}, the returned object can be plotted later using the function \code{plot} which takes as the second argument a list of plotting options (see \code{options} below). \item \code{silhouettes} a logical indicating whether to include a silhouette plot (see Rousseeuw, 1987). \item \code{threshold} a numeric. If used, only plot distances below the threshold are displayed. Consider also using \code{zlim} for this purpose. \item \code{col} colors used for the image plot. \item \code{key} a logical indicating whether to place a color key below the plot. \item \code{zlim} range of values to display (defaults to range \code{x}). \item \code{axes} \code{"auto"} (default; enabled for less than 25 objects), \code{"y"} or \code{"none"}. \item \code{main} title for the plot. \item \code{newpage} a logical indicating whether to start plot on a new page (see \code{\link[=grid.newpage]{grid.newpage()}}. \item \code{pop} a logical indicating whether to pop the created viewports? (see package \pkg{grid}) \item \code{gp}, \code{gp_lines}, \code{gp_labels} objects of class \code{gpar} containing graphical parameters for the plot lines and labels (see \code{\link[=gpar]{gpar()}}. }} \item{...}{\code{dissplot()}: further arguments are added to \code{options}. \code{ggdissplot()} further arguments are passed on to \code{\link[=ggpimage]{ggpimage()}}.} } \value{ \code{dissplot()} returns an invisible object of class \code{cluster_proximity_matrix} with the following elements: \item{order}{\code{NULL} or integer vector giving the order used to plot \code{x}.} \item{cluster_order}{ \code{NULL} or integer vector giving the order of the clusters as plotted.} \item{method}{ vector of character strings indicating the seriation methods used for plotting \code{x}.} \item{k}{ \code{NULL} or integer scalar giving the number of clusters generated.} \item{description}{ a \code{data.frame} containing information (label, size, average intra-cluster dissimilarity and the average silhouette) for the clusters as displayed in the plot (from top/left to bottom/right).} This object can be used for plotting via \code{plot(x, options = NULL, ...)}, where \code{x} is the object and \code{options} contains a list with plotting options (see above). \code{ggdissplot()} returns a ggplot2 object representing the plot. The plot description as an object of class \code{reordered_cluster_dissimilarity_matrix}. } \description{ Visualizes a dissimilarity matrix using seriation and matrix shading using the method developed by Hahsler and Hornik (2011). Entries with lower dissimilarities (higher similarity) are plotted darker. Dissimilarity plots can be used to uncover hidden structure in the data and judge cluster quality. } \details{ The plot can also be used to visualize cluster quality (see Ling 1973). Objects belonging to the same cluster are displayed in consecutive order. The placement of clusters and the within cluster order is obtained by a seriation algorithm which tries to place large similarities/small dissimilarities close to the diagonal. Compact clusters are visible as dark squares (low dissimilarity) on the diagonal of the plot. Additionally, a Silhouette plot (Rousseeuw 1987) is added. This visualization is similar to CLUSION (see Strehl and Ghosh 2002), however, allows for using arbitrary seriating algorithms. \strong{Note:} Since \code{\link[=pimage]{pimage()}} uses \pkg{grid}, it should not be mixed with base R primitive plotting functions. } \examples{ data("iris") # shuffle rows x_iris <- iris[sample(seq(nrow(iris))), -5] d <- dist(x_iris) # Plot original matrix dissplot(d, method = NA) # Plot reordered matrix using the nearest insertion algorithm (from tsp) dissplot(d, method = "TSP", main = "Seriation (TSP)") # Cluster iris with k-means and 3 clusters and reorder the dissimality matrix l <- kmeans(x_iris, centers = 3)$cluster dissplot(d, labels = l, main = "k-means") # show only distances as lower triangle dissplot(d, labels = l, main = "k-means", lower_tri = TRUE, upper_tri = FALSE) # Use a grid layout to place several plots on a page library("grid") grid.newpage() pushViewport(viewport(layout=grid.layout(nrow = 2, ncol = 2), gp = gpar(fontsize = 8))) pushViewport(viewport(layout.pos.row = 1, layout.pos.col = 1)) # Visualize the clustering (using Spectral between clusters and MDS within) res <- dissplot(d, l, method = list(inter = "Spectral", intra = "MDS"), main = "K-Means + Seriation", newpage = FALSE) popViewport() pushViewport(viewport(layout.pos.row = 1, layout.pos.col = 2)) # More visualization options. Note that we reuse the reordered object res! # color: use 10 shades red-blue, biased towards small distances plot(res, main = "K-Means + Seriation (red-blue + biased)", col= bluered(10, bias = .5), newpage = FALSE) popViewport() pushViewport(viewport(layout.pos.row = 2, layout.pos.col = 1)) # Threshold (using zlim) and cubic scale to highlight differences plot(res, main = "K-Means + Seriation (cubic + threshold)", zlim = c(0, 2), col = grays(100, power = 3), newpage = FALSE) popViewport() pushViewport(viewport(layout.pos.row = 2, layout.pos.col = 2)) # Use gray scale with logistic transformation plot(res, main = "K-Means + Seriation (logistic scale)", col = gray( plogis(seq(max(res$x_reordered), min(res$x_reordered), length.out = 100), location = 2, scale = 1/2, log = FALSE) ), newpage = FALSE) popViewport(2) # The reordered_cluster_dissimilarity_matrix object res names(res) ## -------------------------------------------------------------------- ## ggplot-based dissplot if (require("ggplot2")) { library("ggplot2") # Plot original matrix ggdissplot(d, method = NA) # Plot seriated matrix ggdissplot(d, method = "TSP") + labs(title = "Seriation (TSP)") # Cluster iris with k-means and 3 clusters l <- kmeans(x_iris, centers = 3)$cluster ggdissplot(d, labels = l) + labs(title = "K-means + Seriation") # show only lower triangle ggdissplot(d, labels = l, lower_tri = TRUE, upper_tri = FALSE) + labs(title = "K-means + Seriation") # No lines or cluster labels and add a label for the color key (fill) ggdissplot(d, labels = l, cluster_lines = FALSE, cluster_labels = FALSE) + labs(title = "K-means + Seriation", fill = "Distances\n(Euclidean)") # Diverging color palette with manual set midpoint and different seriation methods ggdissplot(d, l, method = list(inter = "Spectral", intra = "MDS")) + labs(title = "K-Means + Seriation", subtitle = "biased color scale") + scale_fill_gradient2(midpoint = median(d)) # Use manipulate scale using package scales library("scales") # Threshold (using limit and na.value) and cubic scale to highlight differences cubic_dist_trans <- trans_new( name = "cubic", # note that we have to do the inverse transformation for distances trans = function(x) x^(1/3), inverse = function(x) x^3 ) ggdissplot(d, l, method = list(inter = "Spectral", intra = "MDS")) + labs(title = "K-Means + Seriation", subtitle = "cubic + biased color scale") + scale_fill_gradient(low = "black", high = "white", limit = c(0,2), na.value = "white", trans = cubic_dist_trans) # Use gray scale with logistic transformation logis_2_.5_dist_trans <- trans_new( name = "Logistic transform (location, scale)", # note that we have to do the inverse transformation for distances trans = function(x) plogis(x, location = 2, scale = .5, log = FALSE), inverse = function(x) qlogis(x, location = 2, scale = .5, log = FALSE), ) ggdissplot(d, l, method = list(inter = "Spectral", intra = "MDS")) + labs(title = "K-Means + Seriation", subtitle = "logistic color scale") + scale_fill_gradient(low = "black", high = "white", trans = logis_2_.5_dist_trans, breaks = c(0, 1, 2, 3, 4)) } } \references{ Hahsler, M. and Hornik, K. (2011): Dissimilarity plots: A visual exploration tool for partitional clustering. \emph{Journal of Computational and Graphical Statistics,} \bold{10}(2):335--354. \doi{10.1198/jcgs.2010.09139} Ling, R.F. (1973): A computer generated aid for cluster analysis. \emph{Communications of the ACM,} \bold{16}(6), 355--361. \doi{10.1145/362248.362263} Rousseeuw, P.J. (1987): Silhouettes: A graphical aid to the interpretation and validation of cluster analysis. \emph{Journal of Computational and Applied Mathematics,} \bold{20}(1), 53--65. \doi{10.1016/0377-0427(87)90125-7} Strehl, A. and Ghosh, J. (2003): Relationship-based clustering and visualization for high-dimensional data mining. \emph{INFORMS Journal on Computing,} \bold{15}(2), 208--230. \doi{10.1287/ijoc.15.2.208.14448} } \seealso{ Other plots: \code{\link{VAT}()}, \code{\link{bertinplot}()}, \code{\link{hmap}()}, \code{\link{palette}()}, \code{\link{pimage}()} } \author{ Michael Hahsler } \concept{plots} \keyword{cluster} \keyword{hplot} seriation/man/ser_permutation.Rd0000644000176200001440000000327014313070703016531 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ser_permutation.R \name{ser_permutation} \alias{ser_permutation} \alias{print.ser_permutation} \alias{summary.ser_permutation} \alias{c.ser_permutation} \alias{[.ser_permutation} \title{Class ser_permutation -- A Collection of Permutation Vectors for Seriation} \usage{ ser_permutation(x, ...) \method{print}{ser_permutation}(x, ...) \method{summary}{ser_permutation}(object, ...) \method{c}{ser_permutation}(..., recursive = FALSE) \method{[}{ser_permutation}(object, i, ...) } \arguments{ \item{x, object}{an object of class \code{ser_permutation_vector} or any object which can be converted into a object of class \code{ser_permutation} (e.g. an integer vector).} \item{...}{vectors for further dimensions.} \item{recursive}{ignored.} \item{i}{index of the dimension(s) to extract.} } \value{ An object of class \code{ser_permutation}. } \description{ The class \code{ser_permutation} is a collection of permutation vectors (see class \link{ser_permutation_vector}), one for each dimension (mode) of the data to be permuted. } \examples{ o <- ser_permutation(1:5, 10:1) o ## length (number of dimensions) length(o) ## get permutation vector for 2nd dimension get_order(o, 2) ## reverse dimensions o[2:1] ## combine o <- c(o, ser_permutation(1:15)) o ## get an individual permutation o[[2]] ## reverse the order of a permutation o[[2]] <- rev(o[[2]]) get_order(o,2) } \seealso{ Other permutation: \code{\link{get_order}()}, \code{\link{permutation_vector2matrix}()}, \code{\link{permute}()}, \code{\link{ser_dist}()}, \code{\link{ser_permutation_vector}()} } \author{ Michael Hahsler } \concept{permutation} \keyword{classes} seriation/man/bertinplot.Rd0000644000176200001440000002003014456113254015473 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/bertinplot.R, R/ggbertinplot.R \name{bertinplot} \alias{bertinplot} \alias{panel.bars} \alias{panel.circles} \alias{panel.rectangles} \alias{panel.squares} \alias{panel.tiles} \alias{panel.blocks} \alias{panel.lines} \alias{bertin_cut_line} \alias{ggbertinplot} \title{Plot a Bertin Matrix} \usage{ bertinplot( x, order = NULL, panel.function = panel.bars, highlight = TRUE, row_labels = TRUE, col_labels = TRUE, flip_axes = TRUE, ... ) panel.bars(value, spacing, hl) panel.circles(value, spacing, hl) panel.rectangles(value, spacing, hl) panel.squares(value, spacing, hl) panel.tiles(value, spacing, hl) panel.blocks(value, spacing, hl) panel.lines(value, spacing, hl) bertin_cut_line(x = NULL, y = NULL, col = "red") ggbertinplot( x, order = NULL, geom = "bar", highlight = TRUE, row_labels = TRUE, col_labels = TRUE, flip_axes = TRUE, prop = FALSE, ... ) } \arguments{ \item{x}{a data matrix. Note that following Bertin, columns are variables and rows are cases. This behavior can be reversed using \code{reverse = TRUE} in \code{options}.} \item{order}{an object of class \code{ser_permutation} to rearrange \code{x} before plotting. If \code{NULL}, no rearrangement is performed.} \item{panel.function}{a function to produce the symbols. Currently available functions are \code{panel.bars} (default), \code{panel.circles}, \code{panel.rectangles}, \code{panel.tiles} and \code{panel.lines}. For circles and squares neg. values are represented by a dashed border. For blocks all blocks are the same size (can be used with \code{shading = TRUE}).} \item{highlight}{a logical scalar indicating whether to use highlighting. If \code{TRUE}, all variables with values greater than the variable-wise mean are highlighted. To control highlighting, also a logical matrix or a matrix with colors with the same dimensions as \code{x} can be supplied.} \item{row_labels, col_labels}{a logical indicating if row and column labels in \code{x} should be displayed. If \code{NULL} then labels are displayed if the \code{x} contains the appropriate dimname and the number of labels is 25 or less. A character vector of the appropriate length with labels can also be supplied.} \item{flip_axes}{logical indicating whether to swap cases and variables in the plot. The default (\code{TRUE}) is to plot cases as columns and variables as rows.} \item{...}{\code{ggbertinplot()}: further parameters are passed on to \code{\link[=ggpimage]{ggpimage()}}. \code{bertinplot()}: further parameters can include: \itemize{ \item \verb{xlab, ylab} labels (default: use labels from \code{x}). \item \code{spacing} relative space between symbols (default: 0.2). \item \code{shading} use gray shades to encode value instead of highlighting (default: \code{FALSE}). \item \code{shading.function} a function that accepts a single argument in range \eqn{[.1, .8]} and returns a valid corresponding color (e.g., using \code{\link[=rgb]{rgb()}}). \item \code{frame} plot a grid to separate symbols (default: \code{FALSE}). \item \code{mar} margins (see \code{\link[=par]{par()}}). \item \code{gp_labels} \code{gpar} object for labels (see \code{\link[=gpar]{gpar()}}) \item \code{gp_panels} \code{gpar} object for panels (see \code{\link[=gpar]{gpar()}}). \item \code{newpage} a logical indicating whether to start the plot on a new page (see \code{\link[=grid.newpage]{grid.newpage()}}). \item \code{pop} a logical indicating whether to pop the created viewports (see \code{\link[=pop.viewport]{pop.viewport()}})? }} \item{value, spacing, hl}{are used internally for the panel functions.} \item{col, y}{and x in \code{bertin_cut_line()} are for adding a line to a \code{bertinplot()} (not ggplot2-based).} \item{geom}{visualization type. Available ggplot2 geometries are: \code{"tile"}, \code{"rectangle"}, \code{"circle"}, \code{"line"}, \code{"bar"}, \code{"none"}.} \item{prop}{logical; change the aspect ratio so cells in the image have a equal width and height.} } \value{ Nothing. } \description{ Plot a data matrix of cases and variables. Each value is represented by a symbol. Large values are highlighted. Note that Bertin arranges the cases horizontally and the variables as rows. The matrix can be rearranged using seriation techniques to make structure in the data visible (see Falguerolles et al 1997). } \details{ The plot is organized as a matrix of symbols. The symbols are drawn by a panel function, where all symbols of a row are drawn by one call of the function (using vectorization). The interface for the panel function is \code{panel.myfunction(value, spacing, hl)}. \code{value} is the vector of values for a row scaled between 0 and 1, \code{spacing} contains the relative space between symbols and \code{hl} is a logical vector indicating which symbol should be highlighted. Cut lines can be added to an existing Bertin plot using \code{bertin_cut_line(x = NULL, y = NULL)}. \code{x}/\code{y} is can be a number indicating where to draw the cut line between two columns/rows. If both \code{x} and \code{y} is specified then one can select a row/column and the other can select a range to draw a line which does only span a part of the row/column. It is important to call \code{bertinplot()} with the option \code{pop = FALSE}. \code{ggbertinplot()} calls \code{\link[=ggpimage]{ggpimage()}} and all additional parameters are passed on. } \examples{ data("Irish") scale_by_rank <- function(x) apply(x, 2, rank) x <- scale_by_rank(Irish[,-6]) # Use the the sum of absolute rank differences order <- c( seriate(dist(x, "minkowski", p = 1)), seriate(dist(t(x), "minkowski", p = 1)) ) # Plot bertinplot(x, order) # Some alternative displays bertinplot(x, order, panel = panel.tiles, shading_col = bluered(100), highlight = FALSE) bertinplot(x, order, panel = panel.circles, spacing = -.2) bertinplot(x, order, panel = panel.rectangles) bertinplot(x, order, panel = panel.lines) # Plot with cut lines (we manually set the order here) order <- ser_permutation(c(6L, 9L, 29L, 10L, 32L, 22L, 2L, 35L, 24L, 30L, 33L, 25L, 37L, 36L, 8L, 27L, 4L, 39L, 3L, 40L, 38L, 1L, 31L, 34L, 28L, 23L, 5L, 11L, 7L, 41L, 13L, 26L, 17L, 15L, 12L, 20L, 14L, 18L, 19L, 16L, 21L), c(4L, 2L, 1L, 6L, 7L, 8L, 5L, 3L)) bertinplot(x, order, pop=FALSE) bertin_cut_line(, 4) ## horizontal line between rows 4 and 5 bertin_cut_line(, 7) ## separate "Right to Life" from the rest bertin_cut_line(18, c(0, 4)) ## separate a block of large values (vertically) # ggplot2-based plots if (require("ggplot2")) { library(ggplot2) # Default plot uses bars and highlighting values larger than the mean ggbertinplot(x, order) # highlight values in the 4th quartile ggbertinplot(x, order, highlight = quantile(x, probs = .75)) # Use different geoms. "none" lets the user specify their own geom. # Variables set are row, col and x (for the value). ggbertinplot(x, order, geom = "tile", prop = TRUE) ggbertinplot(x, order, geom = "rectangle") ggbertinplot(x, order, geom = "rectangle", prop = TRUE) ggbertinplot(x, order, geom = "circle") ggbertinplot(x, order, geom = "line") # Tiles with diverging color scale ggbertinplot(x, order, geom = "tile", prop = TRUE) + scale_fill_gradient2(midpoint = mean(x)) # Custom geom (geom = "none"). Defined variables are row, col, and x for the value ggbertinplot(x, order, geom = "none", prop = FALSE) + geom_point(aes(x = col, y = row, size = x, color = x > 30), pch = 15) + scale_size(range = c(1, 10)) # Use a ggplot2 theme with theme_set() old_theme <- theme_set(theme_minimal() + theme(panel.grid = element_blank()) ) ggbertinplot(x, order, geom = "bar") theme_set(old_theme) } } \references{ de Falguerolles, A., Friedrich, F., Sawitzki, G. (1997): A Tribute to J. Bertin's Graphical Data Analysis. In: Proceedings of the SoftStat '97 (Advances in Statistical Software 6), 11--20. } \seealso{ Other plots: \code{\link{VAT}()}, \code{\link{dissplot}()}, \code{\link{hmap}()}, \code{\link{palette}()}, \code{\link{pimage}()} } \author{ Michael Hahsler } \concept{plots} \keyword{cluster} \keyword{hplot} seriation/man/Chameleon.Rd0000644000176200001440000000242414607571541015220 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Chameleon.R \docType{data} \name{Chameleon} \alias{Chameleon} \alias{chameleon} \alias{chameleon_ds4} \alias{chameleon_ds5} \alias{chameleon_ds7} \alias{chameleon_ds8} \title{2D Data Sets used for the CHAMELEON Clustering Algorithm} \format{ \code{chameleon_ds4}: The format is a 8,000 x 2 data.frame. \code{chameleon_ds5}: The format is a 8,000 x 2 data.frame. \code{chameleon_ds7}: The format is a 10,000 x 2 data.frame. \code{chameleon_ds8}: The format is a 8,000 x 2 data.frame. } \description{ Several 2D data sets created to evaluate the CHAMELEON clustering algorithm in the paper by Karypis et al (1999). } \examples{ data(Chameleon) plot(chameleon_ds4, cex = .1) plot(chameleon_ds5, cex = .1) plot(chameleon_ds7, cex = .1) plot(chameleon_ds8, cex = .1) } \references{ Karypis, G., EH. Han, V. Kumar (1999): CHAMELEON: A Hierarchical Clustering Algorithm Using Dynamic Modeling, \emph{IEEE Computer,} \strong{32}(8): 68--75. \doi{10.1109/2.781637} } \seealso{ Other data: \code{\link{Irish}}, \code{\link{Munsingen}}, \code{\link{SupremeCourt}}, \code{\link{Townships}}, \code{\link{Wood}}, \code{\link{Zoo}}, \code{\link{create_lines_data}()}, \code{\link{is.robinson}()} } \concept{data} \keyword{datasets} seriation/man/seriate_best.Rd0000644000176200001440000001236514607520065015776 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/seriate_best.R \name{seriate_best} \alias{seriate_best} \alias{seriate_rep} \alias{seriate_improve} \title{Best Seriation} \usage{ seriate_best( x, methods = NULL, control = NULL, criterion = NULL, rep = 10L, parallel = TRUE, verbose = TRUE, ... ) seriate_rep( x, method = NULL, control = NULL, criterion = NULL, rep = 10L, parallel = TRUE, verbose = TRUE, ... ) seriate_improve( x, order, criterion = NULL, control = NULL, verbose = TRUE, ... ) } \arguments{ \item{x}{the data.} \item{methods}{a vector of character string with the name of the seriation methods to try.} \item{control}{a list of control options passed on to \code{\link[=seriate]{seriate()}}. For \code{seriate_best()} control needs to be a named list of control lists with the names matching the seriation methods.} \item{criterion}{\code{seriate_rep()} chooses the criterion specified for the method in the registry. A character string with the \link{criterion} to optimize can be specified.} \item{rep}{number of times to repeat the randomized seriation algorithm.} \item{parallel}{logical; perform replications in parallel. Uses \code{\link[foreach:foreach]{foreach::foreach()}} if a \verb{\%dopar\%} backend (e.g., \link[doParallel:doParallel-package]{doParallel::doParallel}) is registered.} \item{verbose}{logical; show progress and results for different methods} \item{...}{further arguments are passed on to the \code{\link[=seriate]{seriate()}}.} \item{method}{a character string with the name of the seriation method (default: varies by data type).} \item{order}{a \code{ser_permutation} object for \code{x} or the name of a seriation method to start with.} } \value{ Returns an object of class \link{ser_permutation}. } \description{ Often the best seriation method for a particular dataset is not know and heuristics may produce unstable results. \code{seriate_best()} and \code{seriate_rep()} automatically try different seriation methods or rerun randomized methods several times to find the best and order given a criterion measure. \code{seriate_improve()} uses a local improvement strategy to imporve an existing solution. } \details{ \code{seriate_rep()} rerun a randomized seriation methods to find the best solution given the criterion specified for the method in the registry. A specific criterion can also be specified. Non-stochastic methods are automatically only run once. \code{seriate_best()} runs a set of methods and returns the best result given a criterion. Stochastic methods are automatically randomly restarted several times. \code{seriate_improve()} improves a seriation order using simulated annealing using a specified criterion measure. It uses \code{\link[=seriate]{seriate()}} with method "\code{GSA}", a reduced probability to accept bad moves, and a lower minimum temperature. Control parameters for this method are accepted. \strong{Criterion} If no criterion is specified, ten the criterion specified for the method in the registry (see \verb{[get_seriation_method()]}) is used. For methods with no criterion in the registry (marked as "other"), a default method is used. The defaults are: \itemize{ \item \code{dist}: \code{"AR_deviations"} - the study in Hahsler (2007) has shown that this criterion has high similarity with most other criteria. \item \code{matrix}: "Moore_stress" } \strong{Parallel Execution} Some methods support for parallel execution is provided using the \link[foreach:foreach]{foreach} package. To use parallel execution, a suitable backend needs to be registered (see the Examples section for using the \link[doParallel:doParallel-package]{doParallel} backend). } \examples{ data(SupremeCourt) d_supreme <- as.dist(SupremeCourt) # find best seriation order (tries by by default several fast methods) o <- seriate_best(d_supreme, criterion = "AR_events") o pimage(d_supreme, o) # run a randomized algorithms several times. It automatically chooses the # LS criterion. Repetition information is returned as attributes o <- seriate_rep(d_supreme, "QAP_LS", rep = 5) attr(o, "criterion") hist(attr(o, "criterion_distribution")) pimage(d_supreme, o) \dontrun{ # Using parallel execution on a larger dataset data(iris) m_iris <- as.matrix(iris[sample(seq(nrow(iris))),-5]) d_iris <- dist(m_iris) library(doParallel) registerDoParallel(cores = detectCores() - 1L) # seriate rows of the iris data set o <- seriate_best(d_iris, criterion = "LS") o pimage(d_iris, o) # improve the order to minimize RGAR instead of LS o_improved <- seriate_improve(d_iris, o, criterion = "RGAR") pimage(d_iris, o_improved) # available control parameters for seriate_improve() get_seriation_method(name = "GSA") } } \references{ Hahsler, M. (2017): An experimental comparison of seriation methods for one-mode two-way data. \emph{European Journal of Operational Research,} \bold{257}, 133--143. \doi{10.1016/j.ejor.2016.08.066} } \seealso{ Other seriation: \code{\link{register_DendSer}()}, \code{\link{register_GA}()}, \code{\link{register_optics}()}, \code{\link{register_smacof}()}, \code{\link{register_tsne}()}, \code{\link{register_umap}()}, \code{\link{registry_for_seriaiton_methods}}, \code{\link{seriate}()} } \author{ Michael Hahsler } \concept{seriation} \keyword{cluster} \keyword{optimize} seriation/man/permute.Rd0000644000176200001440000001064514607517100015001 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/permute.R \name{permute} \alias{permute} \alias{permute.array} \alias{permute.matrix} \alias{permute.data.frame} \alias{permute.table} \alias{permute.numeric} \alias{permute.character} \alias{permute.list} \alias{permute.dist} \alias{permute.dendrogram} \alias{permute.hclust} \title{Permute the Order in Various Objects} \usage{ permute(x, order, ...) \method{permute}{array}(x, order, margin = NULL, ...) \method{permute}{matrix}(x, order, margin = NULL, ...) \method{permute}{data.frame}(x, order, margin = NULL, ...) \method{permute}{table}(x, order, margin = NULL, ...) \method{permute}{numeric}(x, order, ...) \method{permute}{character}(x, order, ...) \method{permute}{list}(x, order, ...) \method{permute}{dist}(x, order, ...) \method{permute}{dendrogram}(x, order, dist = NULL, ...) \method{permute}{hclust}(x, order, dist = NULL, ...) } \arguments{ \item{x}{an object (a list, a vector, a \code{dist} object, a matrix, an array or any other object which provides \code{dim} and standard subsetting with \code{"["}).} \item{order}{an object of class \link{ser_permutation} which contains suitable permutation vectors for \code{x}. Alternatively, a character string with the name of a seriation method appropriate for \code{x} can be specified (see \code{\link[=seriate]{seriate()}}). This will perform seriation and permute \code{x}. The value \code{TRUE} will permute using the default seriation method.} \item{...}{if \code{order} is the name of a seriation method, then additional arguments are passed on to \code{\link[=seriate]{seriate()}}.} \item{margin}{specifies the dimensions to be permuted as a vector with dimension indices. If \code{NULL}, \code{order} needs to contain a permutation for all dimensions. If a single margin is specified, then \code{order} can also contain a single permutation vector. \code{margin} are ignored.} \item{dist}{the distance matrix used to create the dendrogram. Only needed if order is the name of a seriation method.} } \value{ A permuted object of the same class as \code{x}. } \description{ Provides the generic function and methods for permuting the order of various objects including vectors, lists, dendrograms (also \code{hclust} objects), the order of observations in a \code{dist} object, the rows and columns of a matrix or data.frame, and all dimensions of an array given a suitable \link{ser_permutation} object. } \details{ The permutation vectors in \link{ser_permutation} are suitable if the number of permutation vectors matches the number of dimensions of \code{x} and if the length of each permutation vector has the same length as the corresponding dimension of \code{x}. For 1-dimensional/1-mode data (list, vector, \code{dist}), \code{order} can also be a single permutation vector of class \link{ser_permutation_vector} or data which can be automatically coerced to this class (e.g. a numeric vector). For \code{dendrogram} and \code{hclust}, subtrees are rotated to represent the order best possible. If the order is not achieved perfectly then the user is warned. See also \code{\link[=reorder.hclust]{reorder.hclust()}} for reordering \code{hclust} objects. } \examples{ # List data types for permute methods("permute") # Permute matrix m <- matrix(rnorm(10), 5, 2, dimnames = list(1:5, LETTERS[1:2])) m # Permute rows and columns o <- ser_permutation(5:1, 2:1) o permute(m, o) ## permute only columns permute(m, o, margin = 2) ## permute using PCA seriation permute(m, "PCA") ## permute only rows using PCA permute(m, "PCA", margin = 1) # Permute data.frames using heatmap seration (= hierarchical # clustering + optimal leaf ordering) df <- as.data.frame(m) permute(df, "Heatmap") # Permute objects in a dist object d <- dist(m) d permute(d, c(3, 2, 1, 4, 5)) permute(d, "Spectral") # Permute a list l <- list(a = 1:5, b = letters[1:3], c = 0) l permute(l, c(2, 3, 1)) # Permute to reorder dendrogram (see also reorder.hclust) hc <- hclust(d) plot(hc) plot(permute(hc, 5:1)) plot(permute(hc, 5:1, incompartible = "stop")) plot(permute(hc, "OLO", dist = d)) plot(permute(hc, "GW", dist = d)) plot(permute(hc, "MDS", dist = d)) plot(permute(hc, "TSP", dist = d)) } \seealso{ Other permutation: \code{\link{get_order}()}, \code{\link{permutation_vector2matrix}()}, \code{\link{ser_dist}()}, \code{\link{ser_permutation}()}, \code{\link{ser_permutation_vector}()} } \author{ Michael Hahsler } \concept{permutation} \keyword{manip} seriation/man/create_lines_data.Rd0000644000176200001440000001132214607605217016746 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lines_and_ordered_data.R \name{create_lines_data} \alias{create_lines_data} \alias{create_ordered_data} \title{Create Simulated Data for Seriation Evaluation} \usage{ create_lines_data(n = 250) create_ordered_data( n = 250, k = 2, size = NULL, spacing = 6, path = "linear", sd1 = 1, sd2 = 0 ) } \arguments{ \item{n}{number of data points to create.} \item{k}{number of Gaussian components.} \item{size}{relative size (number of points) of components (length of k). If \code{NULL} then all components have the same size.} \item{spacing}{space between the centers of components. The default of 6 means that the components will barely touch at \code{ds1 = 1} (3 standard deviations for each Gaussian component).} \item{path}{Are the components arranged along a \code{"linear"} or \code{"circular"} path?} \item{sd1}{variation in the direction along the components. A value greater than one means the components are mixing.} \item{sd2}{variation perpendicular to the direction along the components. A value greater than 0 will introduce anti-Robinson violation events.} } \value{ a data.frame with the created data. } \description{ Several functions to create simulated data to evaluate different aspects of seriation algorithms and criterion functions. } \details{ \code{create_lines_data()} recreates the lines data set used in for \code{\link[=iVAT]{iVAT()}} in Havens and Bezdeck (2012). \code{create_ordered_data()} (Hahsler et al, 2021) is a versatile function which creates "orderable" 2D data using Gaussian components along a linear or circular path. The components are equally spaced (\code{spacing}) along the path. The default spacing of 6 ensures that 2 adjacent components with a standard deviation of one along the direction of the path will barely touch. The standard deviation along the path is set by \code{sd1}. The standard deviation perpendicular to the path is set by \code{sd2}. A value larger than zero will result in the data not being perfectly orderable (i.e., the resulting distance matrix will not be a perfect pre-anti-Robinson matrix and contain anti-Robinson violation events after seriation). Note that a circular path always creates anti-Robinson violation since the circle has to be broken at some point to create a linear order. } \examples{ ## lines data set from Havens and Bezdek (2011) x <- create_lines_data(100) plot(x, xlim = c(-5, 5), ylim = c(-3, 3), cex = .2, col = attr(x, "id")) d <- dist(x) pimage(d, seriate(d, "OLO_single"), col = bluered(100, bias = .5), key = TRUE) ## create_ordered_data can produce many types of "orderable" data ## perfect pre-Anti-Robinson matrix (with a single components) x <- create_ordered_data(100, k = 1) plot(x, cex = .2, col = attr(x, "id")) d <- dist(x) pimage(d, seriate(d, "MDS"), col = bluered(100, bias=.5), key = TRUE) ## separated components x <- create_ordered_data(100, k = 5) plot(x, cex =.2, col = attr(x, "id")) d <- dist(x) pimage(d, seriate(d, "MDS"), col = bluered(100, bias = .5), key = TRUE) ## overlapping components x <- create_ordered_data(100, k = 5, sd1 = 2) plot(x, cex = .2, col = attr(x, "id")) d <- dist(x) pimage(d, seriate(d, "MDS"), col = bluered(100, bias = .5), key = TRUE) ## introduce anti-Robinson violations (a non-zero y value) x <- create_ordered_data(100, k = 5, sd1 = 2, sd2 = 5) plot(x, cex = .2, col = attr(x, "id")) d <- dist(x) pimage(d, seriate(d, "MDS"), col = bluered(100, bias = .5), key = TRUE) ## circular path (has always violations) x <- create_ordered_data(100, k = 5, path = "circular", sd1 = 2) plot(x, cex = .2, col = attr(x, "id")) d <- dist(x) pimage(d, seriate(d, "OLO"), col = bluered(100, bias = .5), key = TRUE) ## circular path (with more violations violations) x <- create_ordered_data(100, k = 5, path = "circular", sd1 = 2, sd2 = 1) plot(x, cex=.2, col = attr(x, "id")) d <- dist(x) pimage(d, seriate(d, "OLO"), col = bluered(100, bias = .5), key = TRUE) } \references{ Havens, T.C. and Bezdek, J.C. (2012): An Efficient Formulation of the Improved Visual Assessment of Cluster Tendency (iVAT) Algorithm, \emph{IEEE Transactions on Knowledge and Data Engineering,} \strong{24}(5), 813--822. Michael Hahsler, Christian Buchta and Kurt Hornik (2021). seriation: Infrastructure for Ordering Objects Using Seriation. R package version 1.3.2. \url{https://github.com/mhahsler/seriation} } \seealso{ \code{\link[=seriate]{seriate()}}, \code{\link[=criterion]{criterion()}}, \code{\link[=iVAT]{iVAT()}}. Other data: \code{\link{Chameleon}}, \code{\link{Irish}}, \code{\link{Munsingen}}, \code{\link{SupremeCourt}}, \code{\link{Townships}}, \code{\link{Wood}}, \code{\link{Zoo}}, \code{\link{is.robinson}()} } \author{ Michael Hahsler } \concept{data} \keyword{datasets} seriation/man/palette.Rd0000644000176200001440000000441314607520705014757 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/AAA_color_palette.R \name{palette} \alias{palette} \alias{bluered} \alias{palette,} \alias{colors} \alias{greenred} \alias{reds} \alias{blues} \alias{greens} \alias{greys} \alias{grays} \title{Different Useful Color Palettes} \usage{ bluered(n = 100, bias = 1, power = 1, ...) greenred(n = 100, bias = 1, power = 1, ...) reds(n = 100, bias = 1, power = 1, ...) blues(n = 100, bias = 1, power = 1, ...) greens(n = 100, bias = 1, power = 1, ...) greys(n = 100, bias = 1, power = 1, ...) grays(n = 100, bias = 1, power = 1, ...) } \arguments{ \item{n}{number of different colors produces.} \item{bias}{a positive number. Higher values give more widely spaced colors at the high end.} \item{power}{used to control how chroma and luminance is increased (1 = linear, 2 = quadratic, etc.)} \item{...}{further parameters are passed on to \code{\link[=sequential_hcl]{sequential_hcl()}} or \code{\link[=diverging_hcl]{diverging_hcl()}}.} } \value{ A vector with \code{n} colors. } \description{ Defines several color palettes for \code{\link[=pimage]{pimage()}}, \code{\link[=dissplot]{dissplot()}} and \code{\link[=hmap]{hmap()}}. } \details{ The color palettes are created with \code{\link[colorspace:hcl_palettes]{colorspace::sequential_hcl()}} and \code{\link[colorspace:hcl_palettes]{colorspace::diverging_hcl()}}. The two sequential palettes are: \code{reds()} and \code{grays()} (or \code{greys()}). The two diverging palettes are: \code{bluered()} and \code{greenred()}. } \examples{ m <- outer(1:10,1:10) m pimage(m) pimage(m, col = greys(100, power = 2)) pimage(m, col = greys(100, bias = 2)) pimage(m, col = bluered(100)) pimage(m, col = bluered(100, power = .5)) pimage(m, col = bluered(100, bias = 2)) pimage(m - 25, col = greenred(20, bias = 2)) ## choose your own color palettes library(colorspace) hcl_palettes(plot = TRUE) ## blues (with 20 shades) pimage(m, col = colorspace::sequential_hcl(20, "Blues", rev = TRUE)) ## blue to green (aka "Cork") pimage(m, col = colorspace::diverging_hcl(100, "Cork")) } \seealso{ Other plots: \code{\link{VAT}()}, \code{\link{bertinplot}()}, \code{\link{dissplot}()}, \code{\link{hmap}()}, \code{\link{pimage}()} } \author{ Michael Hahsler } \concept{plots} \keyword{hplot} seriation/man/register_umap.Rd0000644000176200001440000000364714607517100016172 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/register_umap.R \name{register_umap} \alias{register_umap} \alias{umap} \title{Register Seriation Based on 1D UMAP} \usage{ register_umap() } \value{ Nothing. } \description{ Use uniform manifold approximation and projection (UMAP) to embed the data on the number line and create a order for \code{\link[=seriate]{seriate()}}. } \details{ Registers the method \code{"umap"} for \code{\link[=seriate]{seriate()}}. This method applies 1D UMAP to a data matrix or a distance matrix and extracts the order from the 1D embedding. Control parameter \code{n_epochs} can be increased to find a better embedding. The returned seriation permutation vector has an attribute named \code{embedding} containing the umap embedding. \bold{Note:} Package \pkg{umap} needs to be installed. } \examples{ \dontrun{ register_umap() ## distances get_seriation_method("dist", "umap") data(SupremeCourt) d <- as.dist(SupremeCourt) o <- seriate(d, method = "umap", verbose = TRUE) pimage(d, o) # look at the returned embedding and plot it attr(o[[1]], "configuration") plot_config(o) ## matrix get_seriation_method("matrix", "umap") data("Zoo") Zoo[,"legs"] <- (Zoo[,"legs"] > 0) x <- as.matrix(Zoo[,-17]) label <- rownames(Zoo) class <- Zoo$class o <- seriate(x, method = "umap", verbose = TRUE) pimage(x, o) plot_config(o[[1]], col = class) } } \references{ McInnes, L, Healy, J, UMAP: Uniform Manifold Approximation and Projection for Dimension Reduction, ArXiv e-prints 1802.03426, 2018 } \seealso{ \code{\link[umap:umap]{umap::umap()}} in \pkg{umap}. Other seriation: \code{\link{register_DendSer}()}, \code{\link{register_GA}()}, \code{\link{register_optics}()}, \code{\link{register_smacof}()}, \code{\link{register_tsne}()}, \code{\link{registry_for_seriaiton_methods}}, \code{\link{seriate}()}, \code{\link{seriate_best}()} } \concept{seriation} \keyword{cluster} \keyword{optimize} seriation/man/Zoo.Rd0000644000176200001440000000354614607606260014077 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Zoo.R \docType{data} \name{Zoo} \alias{Zoo} \title{Zoo Data Set} \format{ A data frame with 101 observations on the following 17 variables. \describe{ \item{\code{hair}}{a numeric vector} \item{\code{feathers}}{a numeric vector} \item{\code{eggs}}{a numeric vector} \item{\code{milk}}{a numeric vector} \item{\code{airborne}}{a numeric vector} \item{\code{aquatic}}{a numeric vector} \item{\code{predator}}{a numeric vector} \item{\code{toothed}}{a numeric vector} \item{\code{backbone}}{a numeric vector} \item{\code{breathes}}{a numeric vector} \item{\code{venomous}}{a numeric vector} \item{\code{fins}}{a numeric vector} \item{\code{legs}}{a numeric vector} \item{\code{tail}}{a numeric vector} \item{\code{domestic}}{a numeric vector} \item{\code{catsize}}{a numeric vector} \item{\code{class}}{a factor with levels \code{amphibian} \code{bird} \code{fish} \code{insect} \code{invertebrate} \code{mammal} \code{reptile}} } } \source{ David Aha, Patrick Murphy, Christopher Merz, Eamonn Keogh, Cathy Blake, Seth Hettich, David Newman, Arthur Asuncion, Moshe Lichman, Dheeru Dua, Casey Graff (2023): UCI Machine Learning Repository, \url{https://archive.ics.uci.edu/}, University of California, Irvine. } \description{ A database containing characteristics of different animals. The database was created and donated by Richard S. Forsyth and is available from the UCI Machine Learning Repository (Newman et al, 1998). } \examples{ data("Zoo") x <- scale(Zoo[, -17]) d <- dist(x) pimage(d) order <- seriate(d, method = "tsp") pimage(d, order) } \seealso{ Other data: \code{\link{Chameleon}}, \code{\link{Irish}}, \code{\link{Munsingen}}, \code{\link{SupremeCourt}}, \code{\link{Townships}}, \code{\link{Wood}}, \code{\link{create_lines_data}()}, \code{\link{is.robinson}()} } \concept{data} \keyword{datasets} seriation/man/Munsingen.Rd0000644000176200001440000000463414607605217015273 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Munsingen.R \docType{data} \name{Munsingen} \alias{Munsingen} \title{Hodson's Munsingen Data Set} \format{ A 59 x 70 0-1 matrix. Rows (graves) and columns (artifacts) are in the order determined by Hodson (1968). } \description{ This data set contains a grave times artifact incidence matrix for the Celtic Münsingen-Rain cemetery in Switzerland as provided by Hodson (1968) and published by Kendall 1971. } \examples{ data("Munsingen") ## Seriation method after Kendall (1971) ## Kendall's square symmetric matrix S and SoS S <- function(x, w = 1) { sij <- function(i , j) w * sum(pmin(x[i,], x[j,])) h <- nrow(x) r <- matrix(ncol = h, nrow =h) for(i in 1:h) for (j in 1:h) r[i,j] <- sij(i,j) r } SoS <- function(x) S(S(x)) ## Kendall's horse shoe (Hamiltonian arc) horse_shoe_plot <- function(mds, sigma, threshold = mean(sigma), ...) { plot(mds, main = paste("Kendall's horse shoe with th =", threshold), ...) l <- which(sigma > threshold, arr.ind=TRUE) for(i in 1:nrow(l)) lines(rbind(mds[l[i,1],], mds[l[i,2],])) } ## shuffle data x <- Munsingen[sample(nrow(Munsingen)),] ## calculate matrix and do isoMDS (from package MASS) sigma <- SoS(x) library("MASS") mds <- isoMDS(1/(1+sigma))$points ## plot Kendall's horse shoe horse_shoe_plot(mds, sigma) ## find order using a TSP library("TSP") tour <- solve_TSP(insert_dummy(TSP(dist(mds)), label = "cut"), method = "2-opt", control = list(rep = 15)) tour <- cut_tour(tour, "cut") lines(mds[tour,], col = "red", lwd = 2) ## create and plot order order <- ser_permutation(tour, 1:ncol(x)) bertinplot(x, order, options= list(panel=panel.circles, rev = TRUE)) ## compare criterion values rbind( random = criterion(x), reordered = criterion(x, order), Hodson = criterion(Munsingen) ) } \references{ Hodson, F.R. (1968). \emph{The La Tene Cemetery at Münsingen-Rain,} Stämpfli, Bern. Kendall, D.G. (1971): Seriation from abundance matrices. In: Hodson, F.R., Kendall, D.G. and Tautu, P., (Editors), \emph{Mathematics in the Archaeological and Historical Sciences,} Edinburgh University Press, Edinburgh, 215--232. } \seealso{ Other data: \code{\link{Chameleon}}, \code{\link{Irish}}, \code{\link{SupremeCourt}}, \code{\link{Townships}}, \code{\link{Wood}}, \code{\link{Zoo}}, \code{\link{create_lines_data}()}, \code{\link{is.robinson}()} } \concept{data} \keyword{datasets} seriation/man/get_order.Rd0000644000176200001440000000666514607517100015301 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/get_order.R \name{get_order} \alias{get_order} \alias{get_order.ser_permutation_vector} \alias{get_order.ser_permutation} \alias{get_order.hclust} \alias{get_order.dendrogram} \alias{get_order.integer} \alias{get_order.numeric} \alias{get_rank} \alias{get_permutation_matrix} \title{Extracting Order Information from a Permutation Object} \usage{ get_order(x, ...) \method{get_order}{ser_permutation_vector}(x, ...) \method{get_order}{ser_permutation}(x, dim = 1, ...) \method{get_order}{hclust}(x, ...) \method{get_order}{dendrogram}(x, ...) \method{get_order}{integer}(x, ...) \method{get_order}{numeric}(x, ...) get_rank(x, ...) get_permutation_matrix(x, ...) } \arguments{ \item{x}{an object of class \link{ser_permutation} or \link{ser_permutation_vector}.} \item{...}{further arguments are ignored for \code{get_order()}. For \code{get_rank()} and for \code{get_permutation_matrix()} the additional arguments are passed on to \code{get_order()} (e.g., as \code{dim}).} \item{dim}{order information for which dimension should be returned?} } \value{ Returns an integer permutation vector/a permutation matrix. } \description{ Method to get the order information from an object of class \link{ser_permutation} or \link{ser_permutation_vector}. Order information can be extracted as a permutation vector, a vector containing each object's rank or a permutation matrix. } \details{ \code{get_order()} returns the permutation as an integer vector which arranges the objects in the seriation order. That is, a vector with the index of the first, second, \eqn{..., n}-th object in the order defined by the permutation. These permutation vectors can directly be used to reorder objects using subsetting with \code{"["}. \emph{Note:} In \pkg{seriation} we usually use these order-based permutation vectors. \strong{Note on names:} While R's \code{\link[=order]{order()}} returns an unnamed vector, \code{get_order()} returns names (if available). The names are the object label corresponding to the index at that position. Therefore, the names in the order are in the order after the permutation. \code{get_rank()} returns the seriation as an integer vector containing the rank/position for each objects after the permutation is applied. That is, a vector with the position of the first, second, \eqn{..., n}-th object after permutation. Note: Use \code{order()} to convert ranks back to an order. \code{get_permutation_matrix()} returns a \eqn{n \times n}{n x n} permutation matrix. } \examples{ ## create a random ser_permutation_vector ## Note that ser_permutation_vector is a single permutation vector x <- structure(1:10, names = paste0("X", 1:10)) o <- sample(x) o p <- ser_permutation_vector(o) p get_order(p) get_rank(p) get_permutation_matrix(p) ## reorder objects using subsetting, the provided permute function or by ## multiplying the with the permutation matrix. We use here x[get_order(p)] permute(x, p) drop(get_permutation_matrix(p) \%*\% x) ## ser_permutation contains one permutation vector for each dimension p2 <- ser_permutation(p, sample(5)) p2 get_order(p2, dim = 2) get_rank(p2, dim = 2) get_permutation_matrix(p2, dim = 2) } \seealso{ Other permutation: \code{\link{permutation_vector2matrix}()}, \code{\link{permute}()}, \code{\link{ser_dist}()}, \code{\link{ser_permutation}()}, \code{\link{ser_permutation_vector}()} } \author{ Michael Hahsler } \concept{permutation} \keyword{manip} seriation/man/Irish.Rd0000644000176200001440000000172614607605217014405 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Irish.R \docType{data} \name{Irish} \alias{Irish} \title{Irish Referendum Data Set} \format{ The format is a 41 x 9 matrix. Two values are missing. } \source{ The data was kindly provided by Guenter Sawitzki. } \description{ A data matrix containing the results of 8 referenda for 41 Irish communities used in Falguerolles et al (1997). } \details{ Column 6 contains the size of the Electorate in 1992. } \examples{ data(Irish) } \references{ de Falguerolles, A., Friedrich, F., Sawitzki, G. (1997) A Tribute to J. Bertin's Graphical Data Analysis. In: \emph{Proceedings of the SoftStat '97 (Advances in Statistical Software 6),} 11--20. } \seealso{ Other data: \code{\link{Chameleon}}, \code{\link{Munsingen}}, \code{\link{SupremeCourt}}, \code{\link{Townships}}, \code{\link{Wood}}, \code{\link{Zoo}}, \code{\link{create_lines_data}()}, \code{\link{is.robinson}()} } \concept{data} \keyword{datasets} seriation/man/register_smacof.Rd0000644000176200001440000000451614607754723016512 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/register_smacof.R \name{register_smacof} \alias{register_smacof} \alias{registersmacof} \alias{smacof} \title{Register Seriation Methods from Package smacof} \usage{ register_smacof() } \value{ Nothing. } \description{ Registers the \code{"MDS_smacof"} method for \code{\link[=seriate]{seriate()}} based on multidimensional scaling using stress majorization and the corresponding \code{"smacof_stress0"} criterion implemented in package smacof (de Leeuw & Mair, 2009). } \details{ Seriation method \code{"smacof"} implements stress majorization with several transformation functions. These functions are passed on as the type control parameter. We default to \code{"ratio"}, which together with \code{"interval"} performs metric MDS. \code{"ordinal"} can be used for non-metric MDS. See \code{\link[smacof:smacofSym]{smacof::smacofSym()}} for details on the control parameters. The corresponding criterion called \code{"smacof_stress0"} is also registered. There additional parameter \code{type} is used to specify the used transformation function. It should agree with the function used for seriation. See \code{\link[smacof:stress0]{smacof::stress0()}} for details on the stress calculation. \strong{Note:} Package \pkg{smacof} needs to be installed. } \examples{ \dontrun{ register_smacof() get_seriation_method("dist", "MDS_smacof") d <- dist(random.robinson(20, pre = TRUE)) ## use Banded AR form with default clustering (complete-link) o <- seriate(d, "MDS_smacof", verbose = TRUE) pimage(d, o) # recalculate stress for the order MDS_stress(d, o) # ordinal MDS. stress needs to be calculated using the correct type with stress0 o <- seriate(d, "MDS_smacof", type = "ordinal", verbose = TRUE) criterion(d, o, method = "smacof_stress0", type = "ordinal") } } \references{ Jan de Leeuw, Patrick Mair (2009). Multidimensional Scaling Using Majorization: SMACOF in R. \emph{Journal of Statistical Software, 31(3),} 1-30. \doi{10.18637/jss.v031.i03} } \seealso{ Other seriation: \code{\link{register_DendSer}()}, \code{\link{register_GA}()}, \code{\link{register_optics}()}, \code{\link{register_tsne}()}, \code{\link{register_umap}()}, \code{\link{registry_for_seriaiton_methods}}, \code{\link{seriate}()}, \code{\link{seriate_best}()} } \concept{seriation} \keyword{cluster} \keyword{optimize} seriation/man/is.robinson.Rd0000644000176200001440000000635314607606260015572 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/robinson.R \name{is.robinson} \alias{is.robinson} \alias{Robinson} \alias{robinson} \alias{random.robinson} \title{Create and Recognize Robinson and Pre-Robinson Matrices} \usage{ is.robinson(x, anti = TRUE, pre = FALSE) random.robinson(n, anti = TRUE, pre = FALSE, noise = 0) } \arguments{ \item{x}{a symmetric, positive matrix or a dissimilarity matrix (a \code{dist} object).} \item{anti}{logical; check for anti Robinson structure? Note that for distances, anti Robinson structure is appropriate.} \item{pre}{logical; recognize/create pre-Robinson matrices.} \item{n}{number of objects.} \item{noise}{noise intensity between 0 and 1. Zero means no noise. Noise more than zero results in non-Robinson matrices.} } \value{ A single logical value. } \description{ Provides functions to create and recognize (anti) Robinson and pre-Robinson matrices. A (anti) Robinson matrix has strictly decreasing (increasing) values when moving away from the main diagonal. A pre-Robinson matrix is a matrix which can be transformed into a perfect Robinson matrix using simultaneous permutations of rows and columns. } \details{ Note that the default matrices are anti Robinson matrices. This is done because distance matrices (the default in R) are typically anti Robinson matrices with values increasing when moving away from the diagonal. Robinson matrices are recognized using the fact that they have zero anti Robinson events. For pre-Robinson matrices we use spectral seriation first since spectral seriation is guaranteed to perfectly reorder pre-Robinson matrices (see Laurent and Seminaroti, 2015). Random pre-Robinson matrices are generated by reversing the process of unidimensional scaling. We randomly (uniform distribution with range \eqn{[0,1]}) choose \eqn{x} coordinates for \code{n} points on a straight line and calculate the pairwise distances. For Robinson matrices, the points are sorted first according to \eqn{x}. For noise, \eqn{y} coordinates is added. The coordinates are chosen uniformly between 0 and \code{noise}, with \code{noise} between 0 and 1. } \examples{ ## create a perfect anti Robinson structure m <- random.robinson(10) pimage(m) is.robinson(m) ## permute the structure to make it not Robinsonian. However, ## it is still pre-Robinson. o <- sample(10) m2 <- permute(m, ser_permutation(o,o)) pimage(m2) is.robinson(m2) is.robinson(m2, pre = TRUE) ## create a binary random Robinson matrix (not anti Robinson) m3 <- random.robinson(10, anti = FALSE) > .7 pimage(m3) is.robinson(m3, anti = FALSE) ## create matrices with noise (as distance matrices) m4 <- as.dist(random.robinson(50, pre = FALSE, noise = .1)) pimage(m4) criterion(m4, method = "AR") m5 <- as.dist(random.robinson(50, pre = FALSE, noise = .5)) pimage(m5) criterion(m5, method = "AR") } \references{ M. Laurent, M. Seminaroti (2015): The quadratic assignment problem is easy for Robinsonian matrices with Toeplitz structure, \emph{Operations Research Letters} \strong{43}(1), 103--109. } \seealso{ Other data: \code{\link{Chameleon}}, \code{\link{Irish}}, \code{\link{Munsingen}}, \code{\link{SupremeCourt}}, \code{\link{Townships}}, \code{\link{Wood}}, \code{\link{Zoo}}, \code{\link{create_lines_data}()} } \concept{data} seriation/man/figures/0000755000176200001440000000000014313070703014464 5ustar liggesusersseriation/man/figures/logo.svg0000644000176200001440000002641214313070703016152 0ustar liggesusersseriationwith RDiscrete Optimizationseriation/man/pimage.Rd0000644000176200001440000002351314457251041014562 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/pimage.R, R/ggpimage.R \name{pimage} \alias{pimage} \alias{pimage.matrix} \alias{pimage.table} \alias{pimage.data.frame} \alias{pimage.dist} \alias{ggpimage} \alias{ggpimage.matrix} \alias{ggpimage.dist} \title{Permutation Image Plot} \usage{ pimage(x, order = FALSE, ...) \method{pimage}{matrix}( x, order = FALSE, col = NULL, main = "", xlab = "", ylab = "", zlim = NULL, key = TRUE, keylab = "", symkey = TRUE, upper_tri = TRUE, lower_tri = TRUE, diag = TRUE, row_labels = NULL, col_labels = NULL, prop = isSymmetric(x), flip_axes = FALSE, reverse_columns = FALSE, ..., newpage = TRUE, pop = TRUE, gp = NULL ) \method{pimage}{table}(x, order = NULL, ...) \method{pimage}{data.frame}(x, order = NULL, ...) \method{pimage}{dist}( x, order = NULL, col = NULL, main = "", xlab = "", ylab = "", zlim = NULL, key = TRUE, keylab = "", symkey = TRUE, upper_tri = TRUE, lower_tri = TRUE, diag = TRUE, row_labels = NULL, col_labels = NULL, prop = TRUE, flip_axes = FALSE, reverse_columns = FALSE, ..., newpage = TRUE, pop = TRUE, gp = NULL ) ggpimage(x, order = NULL, ...) \method{ggpimage}{matrix}( x, order = NULL, zlim = NULL, upper_tri = TRUE, lower_tri = TRUE, diag = TRUE, row_labels = NULL, col_labels = NULL, prop = isSymmetric(x), flip_axes = FALSE, reverse_columns = FALSE, ... ) \method{ggpimage}{dist}( x, order = NULL, zlim = NULL, upper_tri = TRUE, lower_tri = TRUE, diag = TRUE, row_labels = NULL, col_labels = NULL, prop = TRUE, flip_axes = FALSE, reverse_columns = FALSE, ... ) } \arguments{ \item{x}{a matrix, a data.frame, or an object of class \code{dist}.} \item{order}{a logical where \code{FALSE} means no reordering and \code{TRUE} applies a permutation using the default seriation method for the type of \code{x}. Alternatively, any object that can be coerced to class \code{ser_permutation} can be supplied.} \item{\dots}{if \code{order} is the name of a seriation method then further arguments are passed on to the seriation method, otherwise they are ignored.} \item{col}{a list of colors used. If \code{NULL}, a gray scale is used (for matrix larger values are displayed darker and for \code{dist} smaller distances are darker). For matrices containing logical data, black and white is used. For matrices containing negative values a symmetric diverging color palette is used.} \item{main}{plot title.} \item{xlab, ylab}{labels for the x and y axes.} \item{zlim}{vector with two elements giving the range (min, max) for representing the values in the matrix.} \item{key}{logical; add a color key? No key is available for logical matrices.} \item{keylab}{string plotted next to the color key.} \item{symkey}{logical; if \code{x} contains negative values, should the color palate be symmetric (zero is in the middle)?} \item{upper_tri, lower_tri, diag}{a logical indicating whether to show the upper triangle, the lower triangle or the diagonal of the (distance) matrix.} \item{row_labels, col_labels}{a logical indicating if row and column labels in \code{x} should be displayed. If \code{NULL} then labels are displayed if the \code{x} contains the appropriate dimname and the number of labels is 25 or less. A character vector of the appropriate length with labels can also be supplied.} \item{prop}{logical; change the aspect ratio so cells in the image have a equal width and height.} \item{flip_axes}{logical; exchange rows and columns for plotting.} \item{reverse_columns}{logical; revers the order of how the columns are displayed.} \item{newpage, pop, gp}{Start plot on a new page, pop the viewports after plotting, and use the supplied \code{gpar} object (see \pkg{grid}).} } \value{ Nothing. } \description{ Provides methods for matrix shading, i.e., displaying a color image for matrix (including correlation matrices and data frames) and \code{dist} objects given an optional permutation. The plot arranges colored rectangles to represent the values in the matrix. This visualization is also know as a heatmap. Implementations based on the \pkg{grid} graphics engine and based n \pkg{ggplot2} are provided. } \details{ Plots a matrix in its original row and column orientation (\link{image} in \pkg{stats} reverses the rows). This means, in a plot the columns become the x-coordinates and the rows the y-coordinates (in reverse order). \strong{Grid-based plot:} The viewports used for plotting are called: \code{"plot"}, \code{"image"} and \code{"colorkey"}. Use \pkg{grid} functions to manipulate the plots (see Examples section). \strong{ggplot2-based plot:} A ggplot2 object is returned. Colors, axis limits and other visual aspects can be added using standard ggplot2 functions (\code{labs}, \code{scale_fill_continuous}, \code{labs}, etc.). } \examples{ set.seed(1234) data(iris) x <- as.matrix(iris[sample(nrow(iris), 20) , -5]) pimage(x) # Show all labels and flip axes, reverse columns, or change colors pimage(x, prop = TRUE) pimage(x, flip_axes = TRUE) pimage(x, reverse_columns = TRUE) pimage(x, col = grays(100)) # A matrix with positive and negative values x_scaled <- scale(x) pimage(x_scaled) # Use reordering pimage(x_scaled, order = TRUE) pimage(x_scaled, order = "Heatmap") ## Example: Distance Matrix # Show a reordered distance matrix (distances between rows). # Dark means low distance. The aspect ratio is automatically fixed to 1:1 # using prop = TRUE d <- dist(x) pimage(d) pimage(d, order = TRUE) # Supress the upper triangle and diagonal pimage(d, order = TRUE, upper = FALSE, diag = FALSE) # Show only distances that are smaller than 2 using limits on z. pimage(d, order = TRUE, zlim = c(0, 3)) ## Example: Correlation Matrix # we calculate correlation between rows and seriate the matrix # and seriate by converting the correlations into distances. # pimage reorders then rows and columns with c(o, o). r <- cor(t(x)) o <- seriate(as.dist(sqrt(1 - r))) pimage(r, order = c(o, o), upper = FALSE, diag = FALSE, zlim = c(-1, 1), reverse_columns = TRUE, main = "Correlation matrix") # Add to the plot using functions in package grid # Note: pop = FALSE allows us to manipulate viewports library("grid") pimage(x, order = TRUE, pop = FALSE) # available viewports are: "main", "colorkey", "plot", "image" current.vpTree() # Highlight cell 2/2 with a red arrow # Note: columns are x and rows are y. downViewport(name = "image") grid.lines(x = c(1, 2), y = c(-1, 2), arrow = arrow(), default.units = "native", gp = gpar(col = "red", lwd = 3)) # add a red box around the first 4 rows of the 2nd column grid.rect(x = 1 + .5 , y = 4 + .5, width = 1, height = 4, hjust = 0, vjust = 1, default.units = "native", gp = gpar(col = "red", lwd = 3, fill = NA)) ## remove the viewports popViewport(0) ## put several pimages on a page (use grid viewports and newpage = FALSE) # set up grid layout library(grid) grid.newpage() top_vp <- viewport(layout = grid.layout(nrow = 1, ncol = 2, widths = unit(c(.4, .6), unit = "npc"))) col1_vp <- viewport(layout.pos.row = 1, layout.pos.col = 1, name = "col1_vp") col2_vp <- viewport(layout.pos.row = 1, layout.pos.col = 2, name = "col2_vp") splot <- vpTree(top_vp, vpList(col1_vp, col2_vp)) pushViewport(splot) seekViewport("col1_vp") o <- seriate(d) pimage(x, c(o, NA), col_labels = FALSE, main = "Data", newpage = FALSE) seekViewport("col2_vp") ## add the reordered dissimilarity matrix for rows pimage(d, o, main = "Distances", newpage = FALSE) popViewport(0) ##------------------------------------------------------------- ## ggplot2 Examples if (require("ggplot2")) { library("ggplot2") set.seed(1234) data(iris) x <- as.matrix(iris[sample(nrow(iris), 20) , -5]) ggpimage(x) # Show all labels and flip axes, reverse columns ggpimage(x, prop = TRUE) ggpimage(x, flip_axes = TRUE) ggpimage(x, reverse_columns = TRUE) # A matrix with positive and negative values x_scaled <- scale(x) ggpimage(x_scaled) # Use reordering ggpimage(x_scaled, order = TRUE) ggpimage(x_scaled, order = "Heatmap") ## Example: Distance Matrix # Show a reordered distance matrix (distances between rows). # Dark means low distance. The aspect ratio is automatically fixed to 1:1 # using prop = TRUE d <- dist(x) ggpimage(d) ggpimage(d, order = TRUE) # Supress the upper triangle and diagonal ggpimage(d, order = TRUE, upper = FALSE, diag = FALSE) # Show only distances that are smaller than 2 using limits on z. ggpimage(d, order = TRUE, zlim = c(0, 2)) ## Example: Correlation Matrix # we calculate correlation between rows and seriate the matrix r <- cor(t(x)) o <- seriate(as.dist(sqrt(1 - r))) ggpimage(r, order = c(o, o), upper = FALSE, diag = FALSE, zlim = c(-1, 1), reverse_columns = TRUE) + labs(title = "Correlation matrix") ## Example: Custom themes and colors # Reorder matrix, use custom colors, add a title, # and hide colorkey. ggpimage(x) + theme(legend.position = "none") + labs(title = "Random Data") + xlab("Variables") # Add lines ggpimage(x) + geom_hline(yintercept = seq(0, nrow(x)) + .5) + geom_vline(xintercept = seq(0, ncol(x)) + .5) # Use ggplot2 themes with theme_set old_theme <- theme_set(theme_linedraw()) ggpimage(d) theme_set(old_theme) # Use custom color palettes: Gray scale, Colorbrewer (provided in ggplot2) and colorspace ggpimage(d, order = seriate(d), upper_tri = FALSE) + scale_fill_gradient(low = "black", high = "white", na.value = "white") ggpimage(d, order = seriate(d), upper_tri = FALSE) + scale_fill_distiller(palette = "Spectral", direction = +1, na.value = "white") ggpimage(d, order = seriate(d), upper_tri = FALSE) + colorspace::scale_fill_continuous_sequential("Reds", rev = FALSE, na.value = "white") } } \seealso{ Other plots: \code{\link{VAT}()}, \code{\link{bertinplot}()}, \code{\link{dissplot}()}, \code{\link{hmap}()}, \code{\link{palette}()} } \author{ Christian Buchta and Michael Hahsler } \concept{plots} \keyword{hplot} seriation/man/Townships.Rd0000644000176200001440000000223214607571542015321 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Townships.R \docType{data} \name{Townships} \alias{Townships} \title{Bertin's Characteristics of Townships} \format{ A matrix with 16 0-1 variables (columns) indicating the presence (\code{1}) or absence (\code{0}) of characteristics of townships (rows). } \description{ This data contains nine characteristics for 16 townships. The data set was used by Bertin (1981) to illustrate that the conciseness of presentation can be improved by seriating the rows and columns. } \examples{ data("Townships") ## original data pimage(Townships) criterion(Townships) ## seriated data order <- seriate(Townships, method = "BEA", control = list(rep = 5)) pimage(Townships, order) criterion(Townships, order) } \references{ Bertin, J. (1981): \emph{Graphics and Graphic Information Processing}. Berlin, Walter de Gruyter. } \seealso{ Other data: \code{\link{Chameleon}}, \code{\link{Irish}}, \code{\link{Munsingen}}, \code{\link{SupremeCourt}}, \code{\link{Wood}}, \code{\link{Zoo}}, \code{\link{create_lines_data}()}, \code{\link{is.robinson}()} } \author{ Michael Hahsler } \concept{data} \keyword{datasets} seriation/man/uniscale.Rd0000644000176200001440000001026514607606260015127 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/uniscale.R \name{uniscale} \alias{uniscale} \alias{MDS_stress} \alias{get_config} \alias{plot_config} \title{Fit an Unidimensional Scaling for a Seriation Order} \usage{ uniscale(d, order, accept_reorder = FALSE, warn = TRUE, ...) MDS_stress(d, order, refit = TRUE, warn = FALSE) get_config(x, dim = 1L, ...) plot_config(x, main, pch = 19, labels = TRUE, pos = 1, cex = 1, ...) } \arguments{ \item{d}{a dissimilarity matrix.} \item{order}{a precomputed permutation (configuration) order.} \item{accept_reorder}{logical; accept a configuration that does not preserve the requested order. If \code{FALSE}, the initial configuration stored in \code{order} or, an equally spaced configuration is returned.} \item{warn}{logical; produce a warning if the 1D MDS fit does not preserve the given order.} \item{\dots}{additional arguments are passed on to the seriation method.} \item{refit}{logical; forces to refit a minimum-stress MDS configuration, even if \code{order} contains a configuration.} \item{x}{a scaling returned by \code{uniscale()} or a \code{ser_permutation} with a configuration attribute.} \item{dim}{The dimension if \code{x} is a \code{ser_permutation} object.} \item{main}{main plot label} \item{pch}{print character} \item{labels}{add the object names to the plot} \item{pos}{label position for 2D plot (see \code{\link[=text]{text()}}).} \item{cex}{label expansion factor.} } \value{ A vector with the fitted configuration. } \description{ Fits an (approximate) unidimensional scaling configuration given an order. } \details{ This implementation uses the method describes in Maier and De Leeuw (2015) to calculate the minimum stress configuration for a given (seriation) order by performing a 1D MDS fit. If the 1D MDS fit does not preserve the given order perfectly, then a warning is produced indicating for how many positions order could not be preserved. The seriation method which is consistent to uniscale is \code{"MDS_smacof"} which needs to be registered with \code{\link[=register_smacof]{register_smacof()}}. The code is similar to \code{smacof::uniscale()} (de Leeuw, 2090), but scales to larger datasets since it only uses the permutation given by \code{order}. \code{MDS_stress()} calculates the normalized stress of a configuration given by a seriation order. If the order does not contain a configuration, then a minimum-stress configuration if calculates for the given order. All distances are first normalized to an average distance of close to 1 using \eqn{d_{ij} \frac{\sqrt{n(n-1)/2}}{\sqrt{\sum_{i} indicates that in first position is the object with index 3 then the object with index 1 and finally the object with index 2. This representation is often called a (re)arrangement or ordering. The ordering can be extracted from a permutation vector object via \code{\link[=get_order]{get_order()}}. Such an ordering can be directly used to subset the list of original objects with \code{"["} to apply the permutation. \strong{Rank Representation:} An alternative way to specify a permutation is via a list of the ranks of the objects after permutation. This representation is often called a map or substitution. Ranks can be extracted from a permutation vector using \code{\link[=get_rank]{get_rank()}}. \strong{Permutation Matrix:} Another popular representation is a permutation matrix which performs permutations using matrix multiplication. A permutation matrix can be obtained using \code{\link[=get_permutation_matrix]{get_permutation_matrix()}}. \code{ser_permutation_vector} objects are usually packed into a \link{ser_permutation} object which is a collection (a \code{list}) of \eqn{k} permutation vectors for \eqn{k}-mode data. The constructor \code{ser_permutation_vector()} checks if the permutation vector is valid (i.e. if all integers occur exactly once). } \examples{ o <- structure(sample(10), names = paste0("X", 1:10)) o p <- ser_permutation_vector(o, "random") p ## some methods length(p) get_method(p) get_order(p) get_rank(p) get_permutation_matrix(p) r <- rev(p) r get_order(r) ## create a symbolic identity permutation vector (with unknown length) ## Note: This can be used to permute an object, but methods ## like length and get_order are not available. ip <- ser_permutation_vector(NA) ip } \seealso{ Other permutation: \code{\link{get_order}()}, \code{\link{permutation_vector2matrix}()}, \code{\link{permute}()}, \code{\link{ser_dist}()}, \code{\link{ser_permutation}()} } \author{ Michael Hahsler } \concept{permutation} \keyword{classes} seriation/man/registry_for_criterion_methods.Rd0000644000176200001440000001005514610037744021637 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/AAA_registry_criterion.R \docType{data} \name{registry_for_criterion_methods} \alias{registry_for_criterion_methods} \alias{registry_criterion} \alias{list_criterion_methods} \alias{get_criterion_method} \alias{set_criterion_method} \alias{print.criterion_method} \title{Registry for Criterion Methods} \format{ An object of class \code{criterion_registry} (inherits from \code{registry}) of length 21. } \usage{ registry_criterion list_criterion_methods(kind, names_only = TRUE) get_criterion_method(kind, name) set_criterion_method( kind, name, fun, description = NULL, merit = NA, control = list(), verbose = FALSE, ... ) \method{print}{criterion_method}(x, ...) } \arguments{ \item{kind}{the data type the method works on. For example, \code{"dist"}, \code{"matrix"} or \code{"array"}.} \item{names_only}{logical; return only the method name. \code{FALSE} returns also the method descriptions.} \item{name}{the name for the method used to refer to the method in the function \code{\link[=criterion]{criterion()}}.} \item{fun}{a function containing the method's code.} \item{description}{a description of the method. For example, a long name.} \item{merit}{logical; indicating if the criterion measure is a merit (\code{TRUE}) or a loss (\code{FALSE}) measure.} \item{control}{a list with control arguments and default values.} \item{verbose}{logical; print a message when a new method is registered.} \item{...}{further information that is stored for the method in the registry.} \item{x}{an object of class "criterion_method" to be printed.} } \value{ \itemize{ \item \code{list_criterion_method()} results is a vector of character strings with the names of the methods used for \code{criterion()}. \item \code{get_criterion_method()} returns a given method in form of an object of class \code{"criterion_method"}. } } \description{ A registry to manage methods used by \code{\link[=criterion]{criterion()}} to calculate a criterion value given data and a permutation. } \details{ All methods below are convenience methods for the registry named \code{registry_criterion}. \code{list_criterion_method()} lists all available methods for a given data type (\code{kind}). The result is a vector of character strings with the short names of the methods. If \code{kind} is missing, then a list of methods is returned. \code{get_criterion_method()} returns information (including the implementing function) about a given method in form of an object of class \code{"criterion_method"}. With \code{set_criterion_method()} new criterion methods can be added by the user. The implementing function (\code{fun}) needs to have the formal arguments \verb{x, order, ...}, where \code{x} is the data object, order is an object of class \link{ser_permutation_vector} and \code{...} can contain additional information for the method passed on from \code{\link[=criterion]{criterion()}}. The implementation has to return the criterion value as a scalar. } \examples{ ## the registry registry_criterion # List all criterion calculation methods by type list_criterion_methods() # List methods for matrix list_criterion_methods("matrix") # get more description list_criterion_methods("matrix", names_only = FALSE) # get a specific method get_criterion_method(kind = "dist", name = "AR_d") # Define a new method (sum of the diagonal elements) ## 1. implement a function to calculate the measure criterion_method_matrix_foo <- function(x, order, ...) { if(!is.null(order)) x <- permute(x,order) sum(diag(x)) } ## 2. Register new method set_criterion_method("matrix", "DiagSum", criterion_method_matrix_foo, description = "Calculated the sum of all diagonal entries", merit = FALSE) list_criterion_methods("matrix") get_criterion_method("matrix", "DiagSum") ## 3. use all criterion methods (including the new one) criterion(matrix(1:9, ncol = 3)) } \seealso{ This registry uses \link[registry:registry]{registry::registry}. Other criterion: \code{\link{criterion}()} } \author{ Michael Hahsler } \concept{criterion} \keyword{misc} seriation/man/permutation_vector2matrix.Rd0000644000176200001440000000241614607517100020555 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ser_permutation_vector2matrix.R \name{permutation_vector2matrix} \alias{permutation_vector2matrix} \alias{permutation_matrix2vector} \title{Conversion Between Permutation Vector and Permutation Matrix} \usage{ permutation_vector2matrix(x) permutation_matrix2vector(x) } \arguments{ \item{x}{A permutation vector (any object that can be converted into a permutation vector, e.g., a integer vector or a \code{hclust} object) or a matrix representing a permutation. Arguments are checked.} } \value{ \itemize{ \item \code{permutation_vector2matrix()}: returns a permutation matrix. \item \code{permutation_matrix2vector()}: returns the permutation as a integer vector. } } \description{ Converts between permutation vectors and matrices. } \examples{ ## create a random permutation vector pv <- structure(sample(5), names = paste0("X", 1:5)) pv ## convert into a permutation matrix pm <- permutation_vector2matrix(pv) pm ## convert back permutation_matrix2vector(pm) } \seealso{ Other permutation: \code{\link{get_order}()}, \code{\link{permute}()}, \code{\link{ser_dist}()}, \code{\link{ser_permutation}()}, \code{\link{ser_permutation_vector}()} } \author{ Michael Hahsler } \concept{permutation} \keyword{manip} seriation/man/Wood.Rd0000644000176200001440000000253414607606260014234 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Wood.R \docType{data} \name{Wood} \alias{Wood} \title{Gene Expression Data for Wood Formation in Poplar Trees} \format{ The format is a 136 x 6 matrix. } \source{ The data was obtained from \url{http://www.atgc-montpellier.fr/permutmatrix/manual/Exemples/Wood/Wood.htm}. } \description{ A data matrix containing a sample of the normalized gene expression data for 6 locations in the stem of Popla trees published in the study by Herzberg et al (2001). The sample of 136 genes selected by Caraux and Pinloche (2005). } \examples{ data(Wood) head(Wood) } \references{ Hertzberg M., H. Aspeborg, J. Schrader, A. Andersson, R.Erlandsson, K. Blomqvist, R. Bhalerao, M. Uhlen, T. T. Teeri, J. Lundeberg, Bjoern Sundberg, P. Nilsson and Goeran Sandberg (2001): A transcriptional roadmap to wood formation, \emph{PNAS,} \strong{98}(25), 14732--14737. Caraux G. and Pinloche S. (2005): PermutMatrix: a graphical environment to arrange gene expression profiles in optimal linear order, \emph{Bioinformatics,} \strong{21}(7) 1280--1281. } \seealso{ Other data: \code{\link{Chameleon}}, \code{\link{Irish}}, \code{\link{Munsingen}}, \code{\link{SupremeCourt}}, \code{\link{Townships}}, \code{\link{Zoo}}, \code{\link{create_lines_data}()}, \code{\link{is.robinson}()} } \concept{data} \keyword{datasets} seriation/man/register_optics.Rd0000644000176200001440000000275114607606260016532 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/register_optics.R \name{register_optics} \alias{register_optics} \alias{optics} \alias{OPTICS} \title{Register Seriation Based on OPTICS} \usage{ register_optics() } \value{ Nothing. } \description{ Use ordering points to identify the clustering structure (OPTICS) for \code{\link[=seriate]{seriate()}}. } \details{ Registers the method \code{"optics"} for \code{\link[=seriate]{seriate()}}. This method applies the OPTICS ordering algorithm implemented in \code{\link[dbscan:optics]{dbscan::optics()}} to create an ordering. \strong{Note:} Package \pkg{dbscan} needs to be installed. } \examples{ \dontrun{ register_optics() get_seriation_method("dist", "optics") d <- dist(random.robinson(50, pre=TRUE, noise=.1)) o <- seriate(d, method = "optics") pimage(d, o) } } \references{ Mihael Ankerst, Markus M. Breunig, Hans-Peter Kriegel, Joerg Sander (1999). OPTICS: Ordering Points To Identify the Clustering Structure. \emph{ACM SIGMOD international conference on Management of data,} ACM Press, pp. 49-60. \doi{10.1145/304181.304187} } \seealso{ \code{\link[dbscan:optics]{dbscan::optics()}}. Other seriation: \code{\link{register_DendSer}()}, \code{\link{register_GA}()}, \code{\link{register_smacof}()}, \code{\link{register_tsne}()}, \code{\link{register_umap}()}, \code{\link{registry_for_seriaiton_methods}}, \code{\link{seriate}()}, \code{\link{seriate_best}()} } \concept{seriation} \keyword{cluster} \keyword{optimize} seriation/man/seriation-package.Rd0000644000176200001440000000555114610035447016711 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/AAA_seriation-package.R \docType{package} \name{seriation-package} \alias{seriation} \alias{seriation-package} \title{seriation: Infrastructure for Ordering Objects Using Seriation} \description{ Infrastructure for ordering objects with an implementation of several seriation/sequencing/ordination techniques to reorder matrices, dissimilarity matrices, and dendrograms. Also provides (optimally) reordered heatmaps, color images and clustering visualizations like dissimilarity plots, and visual assessment of cluster tendency plots (VAT and iVAT). Hahsler et al (2008) \doi{10.18637/jss.v025.i03}. } \section{Key functions}{ \itemize{ \item Seriation: \code{\link[=seriate]{seriate()}}, \code{\link[=criterion]{criterion()}}, \code{\link[=get_order]{get_order()}}, \code{\link[=permute]{permute()}} \item Visualization: \code{\link[=pimage]{pimage()}}, \code{\link[=bertinplot]{bertinplot()}}, \code{\link[=hmap]{hmap()}}, \code{\link[=dissplot]{dissplot()}}, \code{\link[=VAT]{VAT()}} } } \section{Available seriation methods}{ \itemize{ \item \href{https://mhahsler.github.io/seriation/seriation_methods.html}{A list with the implemented seriation methods} \item \href{https://mhahsler.github.io/seriation/visual_comparison.html}{A visual comparison between seriation methods} \item \href{https://mhahsler.github.io/seriation/seriation_criteria.html}{A list with the implemented seriation criteria} } } \section{Quickstart guides}{ \itemize{ \item \href{https://mhahsler.github.io/seriation/heatmaps.html}{How to reorder heatmaps} \item \href{https://mhahsler.github.io/seriation/correlation_matrix.html}{How to reorder correlation matrices} \item \href{https://mhahsler.github.io/seriation/seriation_cluster_evaluation.html}{How to evaluate clusters using dissimilarity plots} } } \references{ Michael Hahsler, Kurt Hornik, and Christian Buchta. Getting things in order: An introduction to the R package seriation. Journal of Statistical Software, 25(3):1--34, March 2008. \doi{10.18637/jss.v025.i03} } \seealso{ Useful links: \itemize{ \item \url{https://github.com/mhahsler/seriation} \item Report bugs at \url{https://github.com/mhahsler/seriation/issues} } } \author{ \strong{Maintainer}: Michael Hahsler \email{mhahsler@lyle.smu.edu} (\href{https://orcid.org/0000-0003-2716-1405}{ORCID}) [copyright holder] Authors: \itemize{ \item Christian Buchta [copyright holder] \item Kurt Hornik (\href{https://orcid.org/0000-0003-4198-9911}{ORCID}) [copyright holder] } Other contributors: \itemize{ \item David Barnett [contributor] \item Michael Brusco [contributor, copyright holder] \item Michael Friendly [contributor] \item Hans-Friedrich Koehn [contributor, copyright holder] \item Fionn Murtagh [contributor, copyright holder] \item Stephanie Stahl [contributor, copyright holder] } } \keyword{internal} seriation/man/register_DendSer.Rd0000644000176200001440000000520014607606260016545 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/register_DendSer.R \name{register_DendSer} \alias{register_DendSer} \alias{DendSer} \alias{dendser} \title{Register Seriation Methods from Package DendSer} \usage{ register_DendSer() } \value{ Nothing. } \description{ Register the DendSer dendrogram seriation method and the ARc criterion (Earle and Hurley, 2015) for use with \code{\link[=seriate]{seriate()}}. } \details{ Registers the method \code{"DendSer"} for seriate. DendSer is a fast heuristic for reordering dendrograms developed by Earle and Hurley (2015) able to use different criteria. \code{control} for \code{\link[=seriate]{seriate()}} with method \code{"DendSer"} accepts the following parameters: \itemize{ \item \code{"h"} or \code{"method"}: A dendrogram or a method for hierarchical clustering (see \link{hclust}). Default: complete-link. \item \code{"criterion"}: A seriation criterion to optimize (see \code{list_criterion_methods("dist")}. Default: \code{"BAR"} (Banded anti-Robinson from with 20\% band width). \item \code{"verbose"}: a logical; print progress information? \item \code{"DendSer_args"}: additional arguments for \code{\link[DendSer:DendSer]{DendSer::DendSer()}}. } For convenience, the following methods (for different cost functions) are also provided: \itemize{ \item \code{"DendSer_ARc"} (anti-robinson form), \item \code{"DendSer_BAR"} (banded anti-Robinson form), \item \code{"DendSer_LPL"} (lazy path length), \item \code{"DendSer_PL"} (path length). } \strong{Note:} Package \pkg{DendSer} needs to be installed. } \examples{ \dontrun{ register_DendSer() get_seriation_method("dist", "DendSer") d <- dist(random.robinson(20, pre=TRUE)) ## use Banded AR form with default clustering (complete-link) o <- seriate(d, "DendSer_BAR") pimage(d, o) ## use different hclust method (Ward) and AR as the cost function for ## dendrogram reordering o <- seriate(d, "DendSer", control = list(method = "ward.D2", criterion = "AR")) pimage(d, o) } } \references{ D. Earle, C. B. Hurley (2015): Advances in dendrogram seriation for application to visualization. \emph{Journal of Computational and Graphical Statistics,} \strong{24}(1), 1--25. } \seealso{ \code{\link[DendSer:DendSer]{DendSer::DendSer()}} Other seriation: \code{\link{register_GA}()}, \code{\link{register_optics}()}, \code{\link{register_smacof}()}, \code{\link{register_tsne}()}, \code{\link{register_umap}()}, \code{\link{registry_for_seriaiton_methods}}, \code{\link{seriate}()}, \code{\link{seriate_best}()} } \author{ Michael Hahsler based on code by Catherine B. Hurley and Denise Earle } \concept{seriation} \keyword{cluster} \keyword{optimize} seriation/man/register_GA.Rd0000644000176200001440000000524314607573313015521 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/register_GA.R \name{register_GA} \alias{register_GA} \alias{GA} \alias{ga} \alias{gaperm_mixedMutation} \title{Register a Genetic Algorithm Seriation Method} \usage{ register_GA() gaperm_mixedMutation(ismProb = 0.8) } \arguments{ \item{ismProb}{probability to use \code{\link[GA:ga_Mutation]{GA::gaperm_ismMutation()}} (inversion) versus \code{\link[GA:ga_Mutation]{GA::gaperm_simMutation()}} (simple insertion).} } \value{ Nothing. } \description{ Register a GA-based seriation metaheuristic for use with \code{\link[=seriate]{seriate()}}. } \details{ Registers the method \code{"GA"} for \code{\link[=seriate]{seriate()}}. This method can be used to optimize any criterion in package \pkg{seriation}. The GA uses by default the ordered cross-over (OX) operator. For mutation, the GA uses a mixture of simple insertion and simple inversion operators. This mixed operator is created using \code{seriation::gaperm_mixedMutation(ismProb = .8)}, where \code{ismProb} is the probability that the simple insertion mutation operator is used. See package \pkg{GA} for a description of other available cross-over and mutation operators for permutations. The appropriate operator functions in \pkg{GA} start with \code{gaperm_}. We warm start the GA using \code{"suggestions"} given by several heuristics. Set \code{"suggestions"} to \code{NA} to start with a purely random initial population. See Example section for available control parameters. \strong{Note:} Package \pkg{GA} needs to be installed. } \examples{ \dontrun{ register_GA() get_seriation_method("dist", "GA") data(SupremeCourt) d <- as.dist(SupremeCourt) ## optimize for linear seriation criterion (LS) o <- seriate(d, "GA", criterion = "LS", verbose = TRUE) pimage(d, o) ## Note that by default the algorithm is already seeded with a LS heuristic. ## This run is no warm start (no suggestions) and increase run to 100 o <- seriate(d, "GA", criterion = "LS", suggestions = NA, run = 100, verbose = TRUE) pimage(d, o) o <- seriate(d, "GA", criterion = "LS", suggestions = NA, run = 100, verbose = TRUE, ) pimage(d, o) } } \references{ Luca Scrucca (2013): GA: A Package for Genetic Algorithms in R. \emph{Journal of Statistical Software,} \strong{53}(4), 1--37. URL \doi{10.18637/jss.v053.i04}. } \seealso{ Other seriation: \code{\link{register_DendSer}()}, \code{\link{register_optics}()}, \code{\link{register_smacof}()}, \code{\link{register_tsne}()}, \code{\link{register_umap}()}, \code{\link{registry_for_seriaiton_methods}}, \code{\link{seriate}()}, \code{\link{seriate_best}()} } \author{ Michael Hahsler } \concept{seriation} \keyword{cluster} \keyword{optimize} seriation/man/VAT.Rd0000644000176200001440000000570614313070703013751 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/VAT.R, R/ggVAT.R \name{VAT} \alias{VAT} \alias{iVAT} \alias{path_dist} \alias{ggVAT} \alias{ggiVAT} \title{Visual Analysis for Cluster Tendency Assessment (VAT/iVAT)} \usage{ VAT(x, upper_tri = TRUE, lower_tri = TRUE, ...) iVAT(x, upper_tri = TRUE, lower_tri = TRUE, ...) path_dist(x) ggVAT(x, upper_tri = TRUE, lower_tri = TRUE, ...) ggiVAT(x, upper_tri = TRUE, lower_tri = TRUE, ...) } \arguments{ \item{x}{a \code{dist} object.} \item{upper_tri, lower_tri}{a logical indicating whether to show the upper or lower triangle of the VAT matrix.} \item{...}{further arguments are passed on to \code{\link{pimage}} for the regular plots and \code{\link{ggpimage}} for the ggplot2 plots.} } \value{ Nothing. } \description{ Implements Visual Analysis for Cluster Tendency Assessment (VAT; Bezdek and Hathaway, 2002) and Improved Visual Analysis for Cluster Tendency Assessment (iVAT; Wang et al, 2010). } \details{ \code{path_dist()} redefines the distance between two objects as the minimum over the largest distances in all possible paths between the objects as used for iVAT. } \examples{ ## lines data set from Havens and Bezdek (2011) x <- create_lines_data(250) plot(x, xlim=c(-5,5), ylim=c(-3,3), cex=.2) d <- dist(x) ## create regular VAT VAT(d, main = "VAT for Lines") ## same as: pimage(d, seriate(d, "VAT")) ## ggplot2 version if (require("ggplot2")) { ggVAT(d) + labs(title = "VAT") } ## create iVAT which shows visually the three lines iVAT(d, main = "iVAT for Lines") ## same as: ## d_path <- path_dist(d) ## pimage(d_path, seriate(d_path, "VAT for Lines")) ## ggplot2 version if (require("ggplot2")) { ggiVAT(d) + labs(title = "iVAT for Lines") } ## compare with dissplot (shows banded structures and relationship between ## center line and the two outer lines) dissplot(d, method = "OLO_single", main = "Dissplot for Lines", col = bluered(100, bias = .5)) ## compare with optimally reordered heatmap hmap(d, method = "OLO_single", main = "Heatmap for Lines (opt. leaf ordering)", col = bluered(100, bias = .5)) } \references{ Bezdek, J.C. and Hathaway, R.J. (2002): VAT: a tool for visual assessment of (cluster) tendency. \emph{Proceedings of the 2002 International Joint Conference on Neural Networks (IJCNN '02)}, Volume: 3, 2225--2230. Havens, T.C. and Bezdek, J.C. (2012): An Efficient Formulation of the Improved Visual Assessment of Cluster Tendency (iVAT) Algorithm, \emph{IEEE Transactions on Knowledge and Data Engineering,} \bold{24}(5), 813--822. Wang L., U.T.V. Nguyen, J.C. Bezdek, C.A. Leckie and K. Ramamohanarao (2010): iVAT and aVAT: Enhanced Visual Analysis for Cluster Tendency Assessment, \emph{Proceedings of the PAKDD 2010, Part I, LNAI 6118,} 16--27. } \seealso{ Other plots: \code{\link{bertinplot}()}, \code{\link{dissplot}()}, \code{\link{hmap}()}, \code{\link{palette}()}, \code{\link{pimage}()} } \author{ Michael Hahsler } \concept{plots} \keyword{cluster} \keyword{manip} seriation/man/Psych24.Rd0000644000176200001440000000254214607605217014560 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Psych24.R \docType{data} \name{Psych24} \alias{Psych24} \title{Results of 24 Psychological Test for 8th Grade Students} \format{ A 24 x 24 correlation matrix. } \description{ A data set collected by Holzinger and Swineford (1939) which consists of the results of 24 psychological tests given to 145 seventh and eighth grade students in a Chicago suburb. This data set contains the correlation matrix for the 24 test results. The data set was also used as an example for visualization of cluster analysis by Ling (1973). } \examples{ data("Psych24") ## create a dist object and also get rid of the one negative entry in the ## correlation matrix d <- as.dist(1 - abs(Psych24)) pimage(d) ## do hclust as in Ling (1973) hc <- hclust(d, method = "complete") plot(hc) pimage(d, hc) ## use seriation order <- seriate(d, method = "tsp") #order <- seriate(d, method = "tsp", control = list(method = "concorde")) pimage(d, order) } \references{ Holzinger, K. L., Swineford, F. (1939): A study in factor analysis: The stability of a bi-factor solution. \emph{Supplementary Educational Monograph,} No. \strong{48}. Chicago: University of Chicago Press. Ling, R. L. (1973): A computer generated aid for cluster analysis. \emph{Communications of the ACM,} \strong{16}(6), pp. 355--361. } \keyword{datasets} seriation/DESCRIPTION0000644000176200001440000000762614610044272013770 0ustar liggesusersPackage: seriation Type: Package Title: Infrastructure for Ordering Objects Using Seriation Version: 1.5.5 Date: 2024-04-17 Authors@R: c( person("Michael", "Hahsler", role = c("aut", "cre", "cph"), email = "mhahsler@lyle.smu.edu", comment = c(ORCID = "0000-0003-2716-1405")), person("Christian", "Buchta", role = c("aut", "cph")), person("Kurt", "Hornik", role = c("aut", "cph"), comment = c(ORCID = "0000-0003-4198-9911")), person("David", "Barnett", role = c("ctb")), person("Michael", "Brusco", role = c("ctb", "cph")), person("Michael", "Friendly", role = c("ctb")), person("Hans-Friedrich", "Koehn", role = c("ctb", "cph")), person("Fionn", "Murtagh", role = c("ctb", "cph")), person("Stephanie", "Stahl", role = c("ctb", "cph"))) Description: Infrastructure for ordering objects with an implementation of several seriation/sequencing/ordination techniques to reorder matrices, dissimilarity matrices, and dendrograms. Also provides (optimally) reordered heatmaps, color images and clustering visualizations like dissimilarity plots, and visual assessment of cluster tendency plots (VAT and iVAT). Hahsler et al (2008) . Classification/ACM: G.1.6, G.2.1, G.4 URL: https://github.com/mhahsler/seriation BugReports: https://github.com/mhahsler/seriation/issues Depends: R (>= 2.14.0) Imports: ca, cluster, colorspace, foreach, gclus, grDevices, grid, MASS, qap, registry, stats, TSP, vegan Suggests: dbscan, DendSer, dendextend, doParallel, GA, ggplot2, keras, Rtsne, scales, smacof, tensorflow, testthat, umap Encoding: UTF-8 RoxygenNote: 7.3.1 License: GPL-3 Copyright: The code in src/bea.f is Copyright (C) 1991 F. Murtagh; src/bbwrcg.f, src/arsa.f and src/bburcg.f are Copyright (C) 2005 M. Brusco, H.F. Koehn, and S. Stahl. All other code is Copyright (C) Michael Hahsler, Christian Buchta, and Kurt Hornik. Collate: 'AAA_check_installed.R' 'AAA_color_palette.R' 'AAA_defaults.R' 'AAA_map.R' 'AAA_parameters.R' 'AAA_registry_criterion.R' 'AAA_registry_seriate.R' 'AAA_seriation-package.R' 'Chameleon.R' 'Irish.R' 'Munsingen.R' 'Psych24.R' 'SupremeCourt.R' 'Townships.R' 'VAT.R' 'Wood.R' 'Zoo.R' 'bea.R' 'bertinplot.R' 'criterion.R' 'criterion.array.R' 'criterion.dist.R' 'criterion.matrix.R' 'dissplot.R' 'get_order.R' 'ggVAT.R' 'ggbertinplot.R' 'ggdissplot.R' 'hmap.R' 'gghmap.R' 'pimage.R' 'ggpimage.R' 'grid_helpers.R' 'lines_and_ordered_data.R' 'lle.R' 'permute.R' 'register_DendSer.R' 'register_GA.R' 'register_optics.R' 'register_smacof.R' 'register_tsne.R' 'register_umap.R' 'reorder.hclust.R' 'robinson.R' 'ser_dist.R' 'ser_permutation.R' 'ser_permutation_vector.R' 'ser_permutation_vector2matrix.R' 'seriate.R' 'seriate.dist.R' 'seriate.matrix.R' 'seriate.array.R' 'seriate.data.frame.R' 'seriate.table.R' 'seriate_AOE.R' 'seriate_ARSA_Branch-Bound.R' 'seriate_TSP.R' 'seriate_BEA.R' 'seriate_CA.R' 'seriate_GSA.R' 'seriate_HC.R' 'seriate_LLE.R' 'seriate_MDS.R' 'seriate_Mean.R' 'seriate_PCA.R' 'seriate_QAP.R' 'seriate_R2E.R' 'seriate_SGD.R' 'seriate_SPIN.R' 'seriate_VAT.R' 'seriate_best.R' 'seriate_enumerate.R' 'seriate_heatmap.R' 'seriate_identity.R' 'seriate_random.R' 'seriate_reverse.R' 'seriate_spectral.R' 'seriate_vegan.R' 'uniscale.R' NeedsCompilation: yes Packaged: 2024-04-17 21:36:23 UTC; hahsler Author: Michael Hahsler [aut, cre, cph] (), Christian Buchta [aut, cph], Kurt Hornik [aut, cph] (), David Barnett [ctb], Michael Brusco [ctb, cph], Michael Friendly [ctb], Hans-Friedrich Koehn [ctb, cph], Fionn Murtagh [ctb, cph], Stephanie Stahl [ctb, cph] Maintainer: Michael Hahsler Repository: CRAN Date/Publication: 2024-04-17 22:10:02 UTC seriation/build/0000755000176200001440000000000014610040326013342 5ustar liggesusersseriation/build/vignette.rds0000644000176200001440000000033714610040326015704 0ustar liggesusersuQQ 0, !C BCCgI\Ho,]upcG!d" cdbH_B^dNU.xZ+7l"%-(Aԙ4#2ʹr4f#+4= 0)) expect_equal(d[1], 0) ## first two are largest distance (2) w/o reverse d_norev <- ser_dist(x, reverse = FALSE) expect_true(all(d_norev >= 0)) expect_equal(d_norev[1], 2) ## x,y interface d <- ser_dist(x[[1]], x[[2]]) expect_equal(d[1], 0) ## Manhattan is 100 times 50 difference d <- ser_dist(x, method = "Manhattan", reverse = FALSE) expect_true(all(d >=0)) expect_equal(d[1], 100*50) d <- ser_dist(x, method = "Manhattan") expect_true(all(d >=0)) expect_equal(d[1], 0) ## Hamming is 100 d <- ser_dist(x, method = "Hamming", reverse = FALSE) expect_true(all(d >=0)) expect_equal(d[1], 100) d <- ser_dist(x, method = "Hamming") expect_true(all(d >=0)) expect_equal(d[1], 0) ## PPC (reverse has no effect on PPC) d <- ser_dist(x, method = "PPC") expect_true(all(d >=0)) expect_equal(d[1], 0) ## test correlations context("ser_cor") ## Default is Spearman ## sequence with its reverse co <- ser_cor(x[[1]], x[[2]], reverse = FALSE) expect_equal(co, rbind(c(1,-1), c(-1,1))) co <- ser_cor(x, reverse = FALSE) expect_identical(dim(co), rep(length(x), 2)) expect_true(all(co >=-1 & co <=1)) expect_equivalent(co[1:2,1:2], rbind(c(1,-1), c(-1,1))) co <- ser_cor(x) expect_true(all(co >=-1 & co <=1)) expect_equivalent(co[1:2,1:2], rbind(c(1,1), c(1,1))) ### PPC co <- ser_cor(x, method ="PPC") expect_true(all(co >=-1 & co <=1)) expect_equivalent(co[1:2,1:2], rbind(c(1,1), c(1,1))) ## test p-value co <- ser_cor(x, test = TRUE) expect_equivalent(attr(co, "p-value")[1:2,1:2], matrix(0, nrow=2, ncol=2)) co <- ser_cor(x, reverse = TRUE, test = TRUE) expect_equivalent(attr(co, "p-value")[1:2,1:2], matrix(0, nrow=2, ncol=2)) seriation/tests/testthat/test-permuation_vector.R0000644000176200001440000000726114450326712022130 0ustar liggesuserslibrary(testthat) library(seriation) library(dendextend) ## Needed because it redefined all.equal for dendrograms set.seed(0) context("ser_permutation_vector") p <- sample(10) names(p) <- paste0("X", p) sp <- ser_permutation_vector(p, method="valid") expect_identical(length(sp), 10L) expect_identical(get_order(sp), p) expect_identical(get_order(rev(sp)), rev(p)) expect_identical(get_rank(sp), structure(order(p), names = names(p)[order(p)])) expect_error(ser_permutation_vector(c(1:10, 12L), method="invalid"), "Invalid permutation vector!") expect_error(ser_permutation_vector(c(1:10, 3L), method="invalid"), "Invalid permutation vector!") context("ser_permutation") expect_identical(length(ser_permutation(sp)), 1L) expect_identical(length(ser_permutation(sp, sp)), 2L) hc <- hclust(dist(runif(10))) expect_identical(length(ser_permutation(sp, hc)), 2L) hc <- ser_permutation_vector(hc, method="hc") expect_identical(length(ser_permutation(sp, hc, sp)), 3L) expect_identical(length(ser_permutation(ser_permutation(sp), 1:10)), 2L) context("permute") ## vector v <- structure(1:10, names = LETTERS[1:10]) expect_identical(permute(v, ser_permutation(1:10)), v[1:10]) expect_identical(permute(LETTERS[1:10], ser_permutation(1:10)), LETTERS[1:10]) expect_identical(permute(v, ser_permutation(10:1)), v[10:1]) expect_identical(permute(LETTERS[1:10], ser_permutation(10:1)), LETTERS[10:1]) expect_error(permute(v, ser_permutation(1:11))) ## matrix m <- matrix(runif(9), ncol=3, dimnames = list(1:3, LETTERS[1:3])) expect_identical(permute(m, ser_permutation(1:3, 3:1)), m[,3:1]) expect_identical(permute(m, ser_permutation(3:1, 3:1)), m[3:1,3:1]) expect_error(permute(m, ser_permutation(1:10, 1:9))) expect_error(permute(m, ser_permutation(1:9, 1:11))) expect_identical(permute(m, ser_permutation(3:1, 3:1), margin = 1), m[3:1, ]) expect_identical(permute(m, ser_permutation(3:1, 3:1), margin = 2), m[ , 3:1]) expect_identical(permute(m, ser_permutation(3:1), margin = 1), m[3:1, ]) expect_identical(permute(m, ser_permutation(3:1), margin = 2), m[, 3:1]) ## data.frame df <- as.data.frame(m) expect_identical(permute(df, ser_permutation(1:3, 3:1)), df[,3:1]) expect_identical(permute(df, ser_permutation(3:1, 3:1)), df[3:1,3:1]) ## dist d <- dist(matrix(runif(25), ncol=5)) attr(d, "call") <- NULL ### permute removes the call attribute expect_identical(permute(d, ser_permutation(1:5)), d) ### is_equivalent_to ignores attributes expect_equivalent(permute(d, ser_permutation(5:1)), as.dist(as.matrix(d)[5:1,5:1])) expect_error(permute(d, ser_permutation(1:8))) ## list l <- list(a = 1:10, b = letters[1:5], 25) expect_identical(permute(l, 3:1), rev(l)) ## dendrogram ## FIXME: order.dendrogram in stats adds attribute value so I use ## check.attributes = FALSE, but dendrograms use attributes a lot so ## the check may be pointless dend <- as.dendrogram(hclust(d)) expect_equal(dend, permute(dend, get_order(dend)), ignore_attr = TRUE) expect_equal(rev(dend), permute(dend, rev(get_order(dend))), ignore_attr = TRUE) # chances are that a random order will not be perfect o <- sample(5) expect_warning(permute(dend, o)) ## hclust hc <- hclust(d) expect_equal(hc, permute(hc, get_order(hc))) ## Note: rev for hclust adds labels! (So we only compare merge, height and order) #expect_equal(rev(hc), permute(hc, rev(get_order(hc)))) expect_equal(as.hclust(rev(as.dendrogram(hc)))[1:3], permute(hc, rev(get_order(hc)))[1:3]) expect_warning(permute(hc, o)) context("permutation_matrix2vector") pv <- 1:5 pm <- permutation_vector2matrix(pv) expect_true(all(diag(pm) == 1)) pv <- sample(1:100) ## convert into a permutation matrix pm <- permutation_vector2matrix(pv) ## convert back expect_identical(permutation_matrix2vector(pm), pv) seriation/tests/testthat/test-seriate.R0000644000176200001440000002426014535726743020031 0ustar liggesusers### NOTE: disabled snapshot testing since the direction of the order is not defined and randomized ### for some methods. library(seriation) library(testthat) extra_integer <- NULL extra_hclust <- NULL if(seriation:::check_installed("DendSer", "check")) { register_DendSer() extra_hclust <- append(extra_hclust, c("DendSer", "DendSer_ARc", "DendSer_BAR", "DendSer_LPL", "DendSer_PL")) } if(seriation:::check_installed("umap", "check")) { extra_integer <- append(extra_integer, "umap") register_umap() } x <- matrix( c(1, 1, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 1, 1, 1, 1, 0, 1, 1, 1), byrow = TRUE, ncol = 5, dimnames = list(letters[1:4], LETTERS[1:5]) ) d <- dist(x) test_that("test if seriate.dist returns expected results", { cat("\n dist\n") # for cleaner testthat output methods <- list_seriation_methods(kind = "dist") ### insufficient data for metaMDS methods <- setdiff(methods, "metaMDS") os <- sapply(methods, function(m) { cat(" -> testing", format(m, width = 13), "... ") tm <- system.time(o <- seriate(d, method = m)) cat("took", formatC(tm[3], digits = 4), "s.\n") o }) # make sure they are all the right length expect_true(all(sapply(os, length) == nrow(x))) # check which methods produce hclusts and which integers hclusts <- os[sapply(os, function(x) inherits(x, "hclust"))] expect_setequal( object = names(hclusts), expected = c( "GW", "GW_average", "GW_complete", "GW_single", "GW_ward", "HC", "HC_average", "HC_complete", "HC_single", "HC_ward", "OLO", "OLO_average", "OLO_complete", "OLO_single", "OLO_ward", extra_hclust ) ) integers <- os[sapply(os, is.integer)] expect_setequal( object = names(integers), expected = c( "ARSA", "Enumerate", "BBURCG", "BBWRCG", "Identity", "MDS", "MDS_angle", # "metaMDS", "monoMDS", "isomap", "isoMDS", "Sammon_mapping", "QAP_2SUM", "QAP_BAR", "QAP_Inertia", "QAP_LS", "R2E", "Random", "Reverse", "GSA", "SGD", "Spectral", "Spectral_norm", "SPIN_NH", "SPIN_STS", "TSP", "VAT", extra_integer ) ) expect_setequal(c(names(hclusts), names(integers)), expected = names(os)) # check all orders are integers ORDERS <- sapply( X = os, FUN = get_order, dim = 1, simplify = FALSE ) for (o in ORDERS) { expect_type(o, "integer") expect_mapequal(o, expected = c( a = 1, b = 2, c = 3, d = 4 )) expect_type(names(o), "character") } # check $labels of hclust seriation vectors remain in original input order for (n in names(hclusts)) { expect_equal(hclusts[[n]][["labels"]], expected = letters[1:4]) } # check names of get_order() equal to ordered labels for (n in names(hclusts)) { expect_equal(object = names(ORDERS[[n]]), expected = hclusts[[n]][["labels"]][hclusts[[n]][["order"]]]) } # check snapshot of some deterministic methods deterMethods <- c( "BBURCG", "BBWRCG", "GW", "GW_average", "GW_complete", "GW_single", "GW_ward", "HC", "HC_average", "HC_complete", "HC_single", "HC_ward", "Identity", "MDS", "isoMDS", "Sammon_mapping", # this use eigen() which gives slightly different results for OpenBLAS and M1 architecture "MDS_angle", #"R2E", "Spectral", "Spectral_norm", "VAT" ) # recreate with dput(lapply(os[deterMethods], get_order)) correct <- list( BBURCG = c( a = 1L, b = 2L, d = 4L, c = 3L ), BBWRCG = c( a = 1L, b = 2L, d = 4L, c = 3L ), GW = c( a = 1L, b = 2L, d = 4L, c = 3L ), GW_average = c( a = 1L, b = 2L, d = 4L, c = 3L ), GW_complete = c( a = 1L, b = 2L, d = 4L, c = 3L ), GW_single = c( a = 1L, b = 2L, d = 4L, c = 3L ), GW_ward = c( a = 1L, b = 2L, d = 4L, c = 3L ), HC = structure(1:4, names = c("a", "b", "c", "d")), HC_average = structure(1:4, names = c("a", "b", "c", "d")), HC_complete = structure(1:4, names = c("a", "b", "c", "d")), HC_single = structure(1:4, names = c("a", "b", "c", "d")), HC_ward = structure(1:4, names = c("a", "b", "c", "d")), Identity = structure(1:4, names = c("a", "b", "c", "d")), MDS = c( a = 1L, b = 2L, d = 4L, c = 3L ), isoMDS = c( a = 1L, b = 2L, d = 4L, c = 3L ), Sammon_mapping = c( a = 1L, b = 2L, d = 4L, c = 3L ), MDS_angle = c( a = 1L, b = 2L, d = 4L, c = 3L ), R2E = c( c = 3L, d = 4L, b = 2L, a = 1L ), Spectral = c( c = 3L, d = 4L, b = 2L, a = 1L ), Spectral_norm = c(c = 3L, d = 4L, b = 2L, a = 1L), VAT = c(c = 3L, d = 4L, b = 2L, a = 1L)) # Notes: # * some systems may produce the reverse order for some methods! # * ARM-based M1 systems produce different results for eigenvalues. # This is not an error, just a numerical difference. We skip that test for now. #skip_on_os("mac", arch = "aarch64") for (m in deterMethods) expect_true( identical(correct[[m]], get_order(os[[m]])) || identical(correct[[m]], rev(get_order(os[[m]]))), label = paste("Seriation method", m, "does not return the correct order!\n") ) }) # check seriate errors for bad dist objects test_that("test if negative distances and NAs prompt correct seriate.dist errors", { dNeg <- d dNeg[1] <- -1 expect_error(seriate(dNeg), "Negative distances not supported") dNA <- d dNA[1] <- NA expect_error(seriate(dNA), "NAs not allowed in distance matrix x") }) test_that("test if dist objects without Diag or Upper attributes can be permuted", { # eurodist is an object of class dist from built in R package "datasets" expect_s3_class(eurodist, "dist") expect_identical(attr(eurodist, "Diag"), NULL) expect_identical(attr(eurodist, "Upper"), NULL) s <- seriate(eurodist, method = "MDS") expect_s3_class(p <- permute(eurodist, order = s), "dist") expect_false(attr(p, "Diag")) # permutation adds Diag, is this desirable? expect_false(attr(p, "Upper")) expect_equal(labels(p), names(get_order(s))) }) ### Stress test to find memory access problems with randomized algorithms #context("memory stress test") #replicate(1000, seriate(d, method="bburcg")) #replicate(1000, seriate(d, method="bbwrcg")) #replicate(1000, seriate(d, method="arsa")) test_that("test if seriate.matrix returns expected results", { #local_edition(3) # for snapshot testing cat("\n matrix\n") # for cleaner testthat output methods <- list_seriation_methods(kind = "matrix") ### AOE is for symmetric correlation matrices methods <- setdiff(methods, "AOE") os <- sapply(methods, function(m) { cat(" -> testing", format(m, width = 13), "... ") tm <- system.time(o <- seriate(x, method = m)) cat("took", formatC(tm[3], digits = 4), "s.\n") o }, simplify = FALSE) # check number and length of orders expect_true(all(sapply(os, length) == 2L)) expect_true(all(sapply( os, FUN = function(o2) sapply(o2, length) ) == c(4L, 5L))) x_p <- permute(x, os[[1]]) # BEA method expect_equal(x_p, x[get_order(os[[1]], 1), get_order(os[[1]], 2)]) # check labels expect_equal(get_order(os$Identity, 1), c( a = 1, b = 2, c = 3, d = 4 )) expect_equal(get_order(os$Identity, 2), c( A = 1, B = 2, C = 3, D = 4, E = 5 )) expect_equal(get_order(os$Reverse, 2), c( A = 5, B = 4, C = 3, D = 2, E = 1 )) # check snapshot of some deterministic methods #deterMethods <- c("CA", "Identity", "PCA", "PCA_angle", "Reverse") #expect_snapshot(str(os[deterMethods])) }) test_that("test if seriate.matrix with margin returns expected results", { #local_edition(3) # for snapshot testing cat("\n matrix with margin\n") # for cleaner testthat output methods <- list_seriation_methods(kind = "matrix") ### AOE is for symmetric correlation matrices methods <- setdiff(methods, "AOE") os <- sapply(methods, function(m) { cat(" -> testing", format(m, width = 13), "... ") tm <- system.time(o <- seriate(x, method = m, margin = 2)) cat("took", formatC(tm[3], digits = 4), "s.\n") o }, simplify = FALSE) expect_true(all(sapply(os, length) == 2L)) expect_true(all(sapply( os, FUN = function(o2) o2[[1]] ) == 1:4)) expect_true(all(sapply( os, FUN = function(o2) length(o2[[2]]) == 5L ))) x_p <- permute(x, os[[1]], margin = 2) expect_equal(x_p, x[, get_order(os[[1]], 2)]) }) test_that("test if data.frame seriation works as expected", { #local_edition(3) # for snapshot testing df <- as.data.frame(x) o <- seriate(df) expect_silent(permute(df, o)) # defaults work with no messages/warnings expect_warning( permute(df, o[1]), # DEPRECATED: results in a message "permute for data.frames with a single seriation order is now deprecated" ) o <- seriate(df, margin = 1) expect_equal(as.integer(o[[2]]), 1:5) # columns left in original order oPCA <- seriate(df, method = "PCA") #expect_snapshot(permute(df, oPCA)) }) test_that("test if optimizes in registry is a valid criterion", { methods <- list_seriation_methods(names_only = FALSE) expect_no_error({ for (kind in names(methods)) for (m in methods[[kind]]) if (!is.na(m$optimizes)) get_criterion_method(kind, name = m$optimizes) }) }) seriation/tests/testthat/test-zzz_seriate_extra.R0000644000176200001440000000260314456267727022152 0ustar liggesuserslibrary(seriation) library(testthat) ### use zzz in the name so it is done as the last test since it ### registers more methods that should not be tested with the other tests. x <- matrix( c(1, 1, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 1, 1, 1, 1, 0, 1, 1, 1), byrow = TRUE, ncol = 5, dimnames = list(letters[1:4], LETTERS[1:5]) ) d <- dist(x) # Note: tsne does not work with duplicate entries, which is an issue. if(seriation:::check_installed("Rtsne", "check")) { register_tsne() o <- seriate(d, method = "tsne") expect_equal(length(o[[1]]), 4L) #o <- seriate(x, method = "tsne") } if(seriation:::check_installed("dbscan", "check")) { register_optics() o <- seriate(d, method = "optics") expect_equal(length(o[[1]]), 4L) } # this is very slow see we only for 10 iterations skip_on_cran() if(seriation:::check_installed("GA", "check")) { register_GA() o <- seriate(d, "GA", maxiter = 10, parallel = FALSE, verb = F) expect_equal(length(o[[1]]), 4L) } # This produces too many messages # Python (keras) leaves some files in temp and that upsets CRAN skip() # only do 10 epochs. if(seriation:::check_installed("keras", "check")) { suppressMessages({ register_vae() o <- seriate(d, "VAE", epochs = 10) }) expect_equal(length(o[[1]]), 4L) o <- seriate(x, "VAE", epochs = 10) expect_equal(length(o[[1L]]), 4L) expect_equal(length(o[[2L]]), 5L) } seriation/tests/testthat/test-criterion.R0000644000176200001440000000506314452147574020370 0ustar liggesuserslibrary(seriation) m <- matrix(c( 1,1,0,0,0, 1,1,1,0,0, 0,0,1,1,1, 1,0,1,1,1 ), byrow=TRUE, ncol=5) d <- dist(m) as.matrix(d) context("criterion") expect_equal(criterion(d,method="AR_events"), structure(2, names="AR_events")) ## 2 expect_equal(criterion(d,method="Path_length"), structure(4, names="Path_length")) ## 1+2+1=4 expect_equal(criterion(d,method="Lazy_path_length"), structure(8, names="Lazy_path_length")) ## (4-1)*1 + (4-2)*2+ (4-3)*1 = 8 expect_true(zapsmall(round(criterion(d, method="AR_deviations"), 6) - 0.504017) == 0) ## 2.000000 - 1.732051 + 2.236068 - 2.000000 = 0.504017 expect_equal(criterion(d, method="Gradient_raw"), structure(4,names="Gradient_raw")) ## 6 - 2 = 4 expect_true(zapsmall(round(criterion(d, method="Gradient_weighted"), 6) - 3.968119) == 0) ## -1 *(1.000000 - 2.236068 + 1.000000 - 2.000000 + 2.236068 - 2.000000 + 2.000000 - 1.732051 + 1.000000 - 1.732051 + 1.000000 - 2.000000 + 1.732051 - 2.000000 + 2.000000 - 2.236068) ## = 3.968119 ## test stress expect_equal(round(criterion(d, method="Neumann"), 3), structure(7.787, names="Neumann_stress")) expect_equal(round(criterion(d, method="Moore"), 3), structure(11.539, names="Moore_stress")) expect_equal(criterion(m, method="Neumann"), structure(22, names="Neumann_stress")) expect_equal(criterion(m, method="Moore"), structure(44, names="Moore_stress")) ## RGAR ## for w = 2 -> 1/4 ## for w = 3 -> 2/8 expect_error(criterion(d, method="RGAR", w=1)) expect_error(criterion(d, method="RGAR", w=4)) expect_equivalent(criterion(d, method="RGAR", pct=0), .25) expect_equivalent(criterion(d, method="RGAR", w=2), .25) expect_equivalent(round(criterion(d, method="RGAR", pct=100), 3), .25) expect_equivalent(round(criterion(d, method="RGAR", w=3), 3), .25) expect_equivalent(criterion(d, method="RGAR", w=3, relative = FALSE), 2) ### BAR expect_error(criterion(d, method="BAR", b=0), "Band") expect_error(criterion(d, method="BAR", b=4), "Band") # b=1 -> Ham. path length expect_equivalent(criterion(d, method="BAR", b=1), criterion(d, method="Path_length")) # b = n-1 -> ARc expect_equivalent(round(criterion(d, method="BAR", b=3), 3), 21.936) ### Cor R m <- diag(100) expect_equivalent(criterion(m, method="Cor_R"), 1.0) expect_equivalent(criterion(m[nrow(m):1,], method="Cor_R"), -1.0) # this should be close to 0 set.seed(1234) r <- replicate(100, criterion(m[sample(nrow(m)),], method="Cor_R")) # hist(r) expect_true(abs(mean(r)) < 0.1) # test for data.frame and table expect_equal(criterion(as.data.frame(m)), criterion(m)) expect_equal(criterion(as.table(m)), criterion(m)) seriation/tests/testthat.R0000644000176200001440000000010214203251670015365 0ustar liggesuserslibrary("testthat") library("seriation") test_check("seriation") seriation/src/0000755000176200001440000000000014610040327013033 5ustar liggesusersseriation/src/bea.f0000644000176200001440000002661314532153465013754 0ustar liggesusers subroutine rbea(n,m,a,istart,b,ib,ifin) c Reorder rows using BEA, bond energy algorithm. dimension a(n,m), b(n,m), ib(n), ifin(n) c------------------------------------------------------------------------------ c a(n,m) input matrix, rows of which are to be permuted c istart 1st row to be placed c b(n,m) permuted rows to be stored in this array c ib(n) integer list giving permutation carried out c ifin(n) book-keeping vector: is row still active, or has it been c placed (resp. = 1, = 0). c------------------------------------------------------------------------------ c Bond energy algorithm -- see: c c (1) W.T. McCormick, P.J. Schweitzer and T.W. White, c "Problem decomposition and data reorganization by a clustering c technique", Oper. Res., vol. 20, pp. 993-1009, Sept./Oct. 1972. c (2) P. Arabie and L.J. Hubert, c "The bond energy algorithm revisited", IEEE Trans. Syst. Man c Cybern., vol. 20, pp. 268-274, 1990. c (3) P. Arabie, S. Schleutermann, J. Daws and L. Hubert, c "Marketing applications of sequencing and partitioning of c nonsymmetric and/or two-mode matrices", in W. Gaul and M. Schader, c Eds., Data Analysis, Decision Support, and Expert Knowledge c Representation in Marketing, Springer Verlag, 1988, pp. 215-224. c c Implemented by F. Murtagh, Sept. 1991. c------------------------------------------------------------------------------ c c declare variables used later on to prevent warnings about uninitialized variables (MFH) sim1 = 0.0 sim2 = 0.0 iplrow = -1 c c Flags to indicate if row already chosen; 1 = not yet chosen/placed. do 200 i = 1, n ifin(i) = 1 200 continue c c Anticipate 1st placement. 'nplace' = # rows placed. 'nrem' = # remaining. nplace = 1 nrem = n-1 c c Place 1st row ifin(istart) = 0 ib(nplace) = istart do 300 j = 1, m b(1,j) = a(istart,j) 300 continue c 400 continue sim = -100000.0 c insrt = 0 c 'nplace' rows have been placed. c Now want next placement. Have 'nrem' rows still to place. do 900 irow = 1, n if (ifin(irow).eq.1) then c For all still-to-be-placed rows... c 1. Place right at beg.: sim1 = 0.0 do 500 j = 1, m sim1 = sim1 + a(irow,j)*b(1,j) 500 continue c 2. Place right at end: if (nplace.gt.1) then sim2 = 0.0 do 600 j = 1, m sim2 = sim2 + a(irow,j)*b(nplace,j) 600 continue endif c 3. Place between k and k+1, where k = 1, ..., nplace-1: if (nplace.ge.2) then do 800 k = 1, nplace-1 c Path length involves sim with k'th and with k+1'th rows c in 'b'; i.e. b(k,j) and b(k+1,j), for all j. c Sim is with a(irow,j), for all j. sim3 = 0.0 do 700 j = 1, m sim3 = sim3 + a(irow,j)*(b(k,j)+b(k+1,j)) 700 continue if (sim3.gt.sim) then sim = sim3 insrt = k iplrow = irow endif 800 continue endif c c Scale up 'sim1' and 'sim2' relative to 'sim', since former c are based on one link only sim1 = sim1*2.0 sim2 = sim2*2.0 c Use 'sim' and 'insrt' to store final info on row to place. if (sim1.gt.sim) then sim = sim1 insrt = 0 iplrow = irow endif c .ge. in following, to force tied case to end if (sim2.ge.sim) then sim = sim2 insrt = nplace+1 iplrow = irow endif endif 900 continue c c So now, we want to make placement in location 'insrt+1' c 1. This happens to be right at beginning: if (insrt.eq.0) then c Shift right do 1100 l = nplace+1, 2, -1 ib(l) = ib(l-1) do 1000 j = 1, m b(l,j) = b(l-1,j) 1000 continue 1100 continue do 1200 j = 1, m b(1,j) = a(iplrow,j) 1200 continue ifin(iplrow) = 0 nplace = nplace + 1 nrem = nrem - 1 ib(1) = iplrow goto 1900 endif c c 2. Placement happens to be right at end of all current placements: if (insrt.eq.nplace+1) then c Insert after all current placements. do 1300 j = 1, m b(nplace+1,j) = a(iplrow,j) 1300 continue ifin(iplrow) = 0 nplace = nplace + 1 nrem = nrem -1 ib(nplace) = iplrow goto 1900 endif c c 3. If we get to here, new placement is somewhere in the middle. c Shift rows 'insrt+1' to 'nplace', in 'b', right. do 1500 l = nplace+1, insrt+2, -1 ib(l) = ib(l-1) do 1400 j = 1, m b(l,j) = b(l-1,j) 1400 continue 1500 continue do 1600 j = 1, m b(insrt+1,j) = a(iplrow,j) 1600 continue nplace = nplace + 1 nrem = nrem -1 ifin(iplrow) = 0 ib(insrt+1) = iplrow goto 1900 c 1900 continue if (nrem.ge.1) goto 400 c return end c------------------------------------------------------------------------------ subroutine cbea(n,m,a,jstart,b,jb,jfin) c Reoder cols. using BEA, bond energy algorithm. c See references at beg. of routine 'rbea'. dimension a(n,m), b(n,m), jb(m), jfin(m) c------------------------------------------------------------------------------ c a(n,m) input matrix, cols. of which are to be permuted c jstart 1st col. to be placed c b(n,m) permuted cols. to be stored in this array c jb(m) integer list giving permutation carried out c jfin(m) book-keeping vector: is col. still active, or has it been c placed (resp. = 1, = 0). c------------------------------------------------------------------------------ c c declare variables used later on to prevent warnings about uninitialized variables (MFH) jplcol = -1 C c Flags to indicate if col. already chosen do 200 j = 1, m jfin(j) = 1 200 continue c c 'nplace' cols. placed (anticipating!); 'nrem' cols. still to be placed. nplace = 1 nrem = m-1 c c Place 1st col. jfin(jstart) = 0 jb(nplace) = jstart do 300 i = 1, n b(i,1) = a(i,jstart) 300 continue c 400 continue sim = -100000.0 sim1 = 0.0 sim2 = 0.0 insrt = 0 c 'nplace' cols. have been placed. c Now want next placement. Have 'nrem' cols. still to place. do 900 jcol = 1, m if (jfin(jcol).eq.1) then c For all still-to-be-placed cols... c 1. Place right at beg.: sim1 = 0.0 do 500 i = 1, n sim1 = sim1 + a(i,jcol)*b(i,1) 500 continue c 2. Place right at end: if (nplace.gt.1) then sim2 = 0.0 do 600 i = 1, n sim2 = sim2 + a(i,jcol)*b(i,nplace) 600 continue endif c 3. Place between k and k+1, where k = 1, ..., nplace-1: if (nplace.ge.2) then do 800 k = 1, nplace-1 c Path length involves sim with k'th and with k+1'th cols. c in 'b'; i.e. b(i,k) and b(i,k+1), for all i. c Sim is with a(i,jcol), for all i. sim3 = 0.0 do 700 i = 1, n sim3 = sim3 + a(i,jcol)*(b(i,k)+b(i,k+1)) 700 continue if (sim3.gt.sim) then sim = sim3 insrt = k jplcol = jcol endif 800 continue endif c c Scale up 'sim1' and 'sim2' rel. to 'sim' since former are c based on only one link sim1 = 2.0*sim1 sim2 = 2.0*sim2 c Use 'sim' and 'insrt' to store final info. on col. to be placed. if (sim1.gt.sim) then sim = sim1 insrt = 0 jplcol = jcol endif c .ge. in following, to force tied case to end if (sim2.ge.sim) then sim = sim2 insrt = nplace+1 jplcol = jcol endif endif 900 continue c c So now, we want to make placement in location 'insrt+1'. c 1. This happens to be right at beginning. if (insrt.eq.0) then c Shift right do 1100 l = nplace+1, 2, -1 jb(l) = jb(l-1) do 1000 i = 1, n b(i,l) = b(i,l-1) 1000 continue 1100 continue do 1200 i = 1, n b(i,1) = a(i,jplcol) 1200 continue jfin(jplcol) = 0 nplace = nplace + 1 nrem = nrem - 1 jb(1) = jplcol goto 1900 endif c c 2. Placement happens to be right at end of already placed cols. if (insrt.eq.nplace+1) then do 1300 i = 1, n b(i,nplace+1) = a(i,jplcol) 1300 continue jfin(jplcol) = 0 nplace = nplace + 1 nrem = nrem -1 jb(nplace) = jplcol goto 1900 endif c c 3. New col. placement happens to be somewhere in the middle. c Shift cols. 'insrt+1' to 'nplace', in 'b', right. do 1500 l = nplace+1, insrt+2, -1 jb(l) = jb(l-1) do 1400 i = 1, n b(i,l) = b(i,l-1) 1400 continue 1500 continue do 1600 i = 1, n b(i,insrt+1) = a(i,jplcol) 1600 continue nplace = nplace + 1 nrem = nrem -1 jfin(jplcol) = 0 jb(insrt+1) = jplcol goto 1900 c 1900 continue if (nrem.ge.1) goto 400 c return end c-------------------------------------------------------------------------- subroutine energy(n,m,b,ener) dimension b(n,m) c Det. "bond energy" of array b c I.e. product of each elt. with its 4 nearest neighbors, c summed over all elts. ener = 0.0 c Corner elts. ener = ener + b(1,1)*(b(1,2)+b(2,1)) ener = ener + b(1,m)*(b(1,m-1)+b(2,m)) ener = ener + b(n,1)*(b(n-1,1)+b(n,2)) ener = ener + b(n,m)*(b(n-1,m)+b(n,m-1)) c Next non-corner border elts. do 100 j = 2, m-1 ener = ener + b(1,j)*(b(1,j-1)+b(1,j+1)+b(2,j)) ener = ener + b(n,j)*(b(n,j-1)+b(n,j+1)+b(n-1,j)) 100 continue do 200 i = 2, n-1 ener = ener + b(i,1)*(b(i-1,1)+b(i+1,1)+b(i,2)) ener = ener + b(i,m)*(b(i-1,m)+b(i+1,m)+b(i,m-1)) 200 continue c Finally, all non-border elts. do 400 i = 2, n-1 do 300 j = 2, m-1 ener = ener + b(i,j)*(b(i-1,j)+b(i+1,j)+b(i,j-1)+b(i,j+1)) 300 continue 400 continue c return end seriation/src/pathdist.c0000644000176200001440000000274714313070703015032 0ustar liggesusers/* * seriation - Infrastructure for seriation * Copyrigth (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik * * 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 2 of the License, or * 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, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. */ #include #include #include "lt.h" /* Calculate the path distance for iVAT */ /* Note this changes A! */ /* FIXME: INF and NA */ SEXP pathdist_floyd(SEXP R_x) { int *dimX = INTEGER( GET_DIM(R_x) ); R_xlen_t i, j, k, n = dimX[0]; SEXP R_y; double *x = REAL(R_x); double *y; PROTECT(R_y = allocMatrix(REALSXP, dimX[0], dimX[1])); y = REAL(R_y); /* initialize y with paths of length 1 */ for(i=0; i #include /* compute the length of an order, i.e. the sum of * the edge weights along the path defined by the * order. * * note that the order is a tour with the leg between * the first and the last city omitted. * * ceeboo 2005 */ static double orderLength(double *x, int *o, int n) { double v, z; R_xlen_t i, j, k; z = 0; /* path length */ i = o[0]; for (k = 0; k < n-1; k++) { j = o[k+1]; if (i > j) v = x[i+j*(n-1)-j*(j+1)/2-1]; else if (i == j) return NA_REAL; else v = x[j+i*(n-1)-i*(i+1)/2-1]; if (!R_FINITE(v)) return NA_REAL; z += v; i = j; } return z; } /* R wrapper */ SEXP order_length(SEXP R_dist, SEXP R_order) { R_xlen_t n, k; int *o; SEXP R_obj; n = LENGTH(R_order); if (LENGTH(R_dist) != n * (n - 1) / 2) error("order_length: length of \"dist\" and \"order\" do not match"); o = Calloc(n, int); for (k = 0; k < n; k++) /* offset to C indexing */ o[k] = INTEGER(R_order)[k]-1; PROTECT(R_obj = NEW_NUMERIC(1)); REAL(R_obj)[0] = orderLength(REAL(R_dist), o, n); Free(o); UNPROTECT(1); return R_obj; } /* check validity of a merge tree representation */ int checkRmerge(int *x, int n) { R_xlen_t k; int v; if (x[0] > 0 || x[n-1] > 0) /* initial merge */ return 0; for (k = 0; k < 2*(n-1); k++) { v = x[k]; if (v < -n || v > n-1) return 0; if (v > 0 && v > k+1) return 0; } return 1; } /* Z. Bar-Joseph, E. D. Demaine, D. K. Gifford, and T. Jaakkola. * (2001) Fast Optimal Leaf Ordering for Hierarchical Clustering. * Bioinformatics, Vol. 17 Suppl. 1, pp. 22-29. * * this implementation builds on the improvements of a more recent paper * available at the website of Bar-Joseph! * * as input we exepct a matrix with the distances in the lower triangle, * a merge tree, i.e. two arrays holding n-1 indexes of the left and right * subtrees (or leaves) merged at the kth step (for details see dist and * hclust). * * returns a list with a matrix (merge) and two vectors (order and length). * * The algorithm has the following stages: * * 1) find a leaf ordering consistent with the supplied merge tree. * the order of the leaves of a tree consists of the order of the * leaves in the left subtree followed by the order of the leaves * in the right subtree. * * note that the tree (leaf) indexes must have an offset of one because * the leaves are coded as negative numbers. subtrees are referenced by * their position in the merge sequence (see hclust). this sucks! * * we compute for each left and right subtree the offset of the leftmost * leaf in the total order of leaves, and the number of leaves in both * trees, i.e. in the parent tree. * * 2) recursively compute for each pair of outer endpoints, i.e. a left * endpoint from the left subtree and a right endpoint from the right * subtree the length of the optimal ordering of the leaves. * * the temporary tables are stored in the lower triangle as well as the * similarities. the lengths of the best linear orderings are stored in * the upper triangle. * * for the improved computations at the root the diagonal is used as * storage for temporary results. * * the time complexity of finding all the partial optimal leaf orderings * is O(n^3). * * the suggested improvement based on early termination of the search is * currently not implemented. however, ties are broken randomly. * * 3) recursively find the total optimal leaf ordering. * * 4) find the merge tree corresponding to the optimal ordering. * * fixme: using similarities would allow a remapping of non-finite * values to zero and thus sanitizing of overflows. also for * missing values this would be a more user friendly approach. * * (C) ceeboo 2005 */ static int calcAllOrder(double *x, int *e, int *oi, int *ok, int *oj, int ci, int ck, int cj, int n) { R_xlen_t i, ii, j, jj, k, kk, h = 0, l; double s, z; for (i = 0; i < ci; i++) { ii = oi[i]; for (j = 0; j < cj; j++) { jj = oj[j]; l = 0; z = R_PosInf; for (k = 0; k < ck; k++) { kk = ok[k]; if (ii > kk) s = x[kk+ii*n]; else s = x[ii+kk*n]; if (kk > jj) s += x[kk+jj*n]; else s += x[jj+kk*n]; if (s < z) { z = s; h = kk; l = 1; } else if (s == z) { if (unif_rand() > (double) l/(l+1)) h = kk; l++; } } if (!R_FINITE(z)) return 0; /* error */ if (ii > jj) x[jj+ii*n] = z; else x[ii+jj*n] = z; e[ii+jj*n] = h; } } return 1; } static int calcEndOrder(double *x, int *e, int *oi, int *ok, int ci, int ck, int n) { R_xlen_t i, ii, k, kk, h = 0, l; double s, z; for (i = 0; i < ci; i++) { ii = oi[i]; l = 0; z = R_PosInf; for (k = 0; k < ck; k++) { kk = ok[k]; if (ii > kk) s = x[kk+ii*n]; else s = x[ii+kk*n]; if (s < z) { z = s; h = kk; l = 1; } else if (s == z) { if (unif_rand() > (double) l/(l+1)) h = kk; l++; } } if (!R_FINITE(z)) return 0; x[ii+ii*n] = z; e[ii+ii*n] = h; } return 1; } static int debug = FALSE; SEXP order_optimal(SEXP R_dist, SEXP R_merge) { R_xlen_t n, i, ii, j, jj, k, kk, h, a = 0, b = 0; int cl = 0, cll = 0, clr = 0, cr = 0, crl = 0, crr = 0; int *l, *r, *c, *e; int *left, *right, *o, *ol = 0, *oll = 0, *olr = 0, *or = 0, *orl = 0, *orr = 0; double s, z, zz; double *x; SEXP R_obj; n = 1 + (int) sqrt(2 * LENGTH(R_dist)); if (LENGTH(R_dist) < 3 || LENGTH(R_dist) != n*(n-1)/2) error("order_optimal: invalid length"); if (LENGTH(GET_DIM(R_merge)) != 2) error("order_optimal: \"merge\" invalid"); if (INTEGER(GET_DIM(R_merge))[0] != n-1) error("order_optimal: \"dist\" and \"merge\" do not conform"); if (!checkRmerge(INTEGER(R_merge), n)) error("order_optimal: \"merge\" invalid"); /* copy similarities into lower triangle */ x = Calloc(n*n, double); /* data + part order lengths + temporary */ k = 0; for (i = 0; i < n-1; i++) for (j = i+1; j < n; j++) { z = REAL(R_dist)[k++]; if (!R_FINITE(z)) { Free(x); error("order_optimal: \"dist\" invalid"); } else x[j+i*n] = z; } PROTECT(R_obj = NEW_LIST(3)); /* result list */ SET_ELEMENT(R_obj, 0, duplicate(R_merge)); /* merge */ SET_ELEMENT(R_obj, 1, NEW_INTEGER(n)); /* order */ SET_ELEMENT(R_obj, 2, NEW_NUMERIC(1)); /* length */ left = INTEGER(VECTOR_ELT(R_obj, 0)); right = INTEGER(VECTOR_ELT(R_obj, 0))+n-1; o = INTEGER(VECTOR_ELT(R_obj, 1)); GetRNGstate(); l = Calloc(n, int); /* offset of leftmost leaf of left tree */ r = Calloc(n, int); /* offset of leftmost leaf of right tree; * reverse mapping of order */ c = Calloc(n-1, int); /* number of leaves in a tree */ e = Calloc(n*n, int); /* inner endpoints */ /* for each tree count the number of leaves. */ for (k = 0; k < n-1; k++) { if (left[k] > 0) c[k] += c[left[k]-1]; else c[k] = 1; if (right[k] > 0) c[k] += c[right[k]-1]; else c[k] += 1; } /* backpropagate the counts to obtain the current * leaf order and the offset of the leftmost leaf * of the left and right subtree. */ for (k = n-2; k >= 0; k--) { if (left[k] > 0) { h = l[k] + c[left[k]-1]; if (right[k] > 0) l[right[k]-1] = h; else o[h] = -right[k]-1; l[left[k]-1] = l[k]; } else { h = l[k] + 1; if (right[k] > 0) l[right[k]-1] = h; else o[h] = -right[k]-1; o[l[k]] = -left[k]-1; } r[k] = h; } /* determine for each subtree the optimal order * for each pair of left and right endpoints * (leaves). this is done in the order provided * by the merge tree. */ for (k = 0; k < n-1; k++) { ol = o + l[k]; /* order of left subtree */ or = o + r[k]; /* order of right subtree */ cl = r[k] - l[k]; /* number of leaves in left subtree */ cr = c[k] - cl; /* number of leaves in right subtree */ if (cl > 1) { /* a left tree */ h = left[k]-1; oll = o + l[h]; olr = o + r[h]; cll = r[h] - l[h]; clr = c[h] - cll; } else { /* a left leaf */ oll = olr = ol; cll = clr = cl; } if (cr > 1) { /* a right tree */ h = right[k]-1; orl = o + l[h]; orr = o + r[h]; crl = r[h] - l[h]; crr = c[h] - crl; } else { /* a right leaf */ orl = orr = or; crl = crr = cr; } if (k == n-2) /* optimized search at the root */ break; /* compute temporary sums for all endpoints */ if (!calcAllOrder(x, e, oll, olr, or, cll, clr, cr, n)) { Free(x); Free(r); Free(l); Free(c); Free(e); error("order_optimal: non-finite values"); } if (olr != oll) if (!calcAllOrder(x, e, olr, oll, or, clr, cll, cr, n)) { Free(x); Free(r); Free(l); Free(c); Free(e); error("order_optimal: non-finite values"); } /* copy temporary sums to lower triangle */ for (i = 0; i < cl; i++) { ii = ol[i]; for (j = 0; j < cr; j++) { jj = or[j]; if (ii > jj) x[ii+jj*n] = x[jj+ii*n]; else x[jj+ii*n] = x[ii+jj*n]; } } /* compute best orders for all endpoints */ if (!calcAllOrder(x, e, orl, orr, ol, crl, crr, cl, n)) { Free(x); Free(r); Free(l); Free(c); Free(e); error("order_optimal: non-finite values"); } if (orr != orl) if (!calcAllOrder(x, e, orr, orl, ol, crr, crl, cl, n)) { Free(x); Free(r); Free(l); Free(c); Free(e); error("order_optimal: non-finite values"); } /* now that we know both endpoints we can store * the inner endpoint from the left tree at the * correct addresse. */ for (i = 0; i < cr; i++) { ii = or[i]; for (j = 0; j < cl; j++) { jj = ol[j]; kk = e[ii+jj*n]; if (ii > jj) x[ii+jj*n] = (double) e[jj+kk*n]; else x[jj+ii*n] = (double) e[jj+kk*n]; } } /* copy back */ for (i = 0; i < cl; i++) { ii = ol[i]; for (j = 0; j < cr; j++) { jj = or[j]; if (ii > jj) e[ii+jj*n] = (int) x[ii+jj*n]; else e[ii+jj*n] = (int) x[jj+ii*n]; } } } /* find the best linear order for each endpoint * of the left and right subtree of the root */ if (!calcEndOrder(x, e, oll, olr, cll, clr, n)) { Free(x); Free(r); Free(l); Free(c); Free(e); error("order_optimal: non-finite values"); } if (olr != oll) if (!calcEndOrder(x, e, olr, oll, clr, cll, n)) { Free(x); Free(r); Free(l); Free(c); Free(e); error("order_optimal: non-finite values"); } if (!calcEndOrder(x, e, orl, orr, crl, crr, n)) { Free(x); Free(r); Free(l); Free(c); Free(e); error("order_optimal: non-finite values"); } if (orr != orl) if (!calcEndOrder(x, e, orr, orl, crr, crl, n)) { Free(x); Free(r); Free(l); Free(c); Free(e); error("order_optimal: non-finite values"); } /* find the best linear order at the root */ k = 0; z = R_PosInf; for (i = 0; i < cl; i++) { ii = ol[i]; zz = x[ii+ii*n]; for (j = 0; j < cr; j++) { jj = or[j]; s = zz + x[jj+jj*n]; if (ii > jj) s += x[ii+jj*n]; else s += x[jj+ii*n]; if (s < z) { z = s; a = ii; b = jj; k = 1; } else if (s == z) { if (unif_rand() > (double) k/(k+1)) { a = ii; b = jj; } k++; } } if (!R_FINITE(z)) { Free(x); Free(r); Free(l); Free(c); Free(e); error("order_optimal: non-finite values"); } } REAL(VECTOR_ELT(R_obj, 2))[0] = z; /* set length */ /* the order can be found by double recursion. * for this we use a stack, one for the left * and one for the right endpoints. */ l[0] = b; /* push endpoints of right tree on the stack*/ r[0] = e[b+b*n]; i = e[a+a*n]; /* start with endpoints of left tree */ j = a; h = 0; k = 1; while (h < n) { if (i == j) { /* backtrack */ o[h++] = i; k--; if (k < 0) break; i = l[k]; /* pop endpoints */ j = r[k]; } else { l[k] = e[j+i*n]; /* push endpoints of right tree on the stack */ r[k] = j; k++; j = e[i+j*n]; /* recurse left tree */ } } /* adjust the merge tree to the optimal order * * 1) for each pair of leaves from a left and right * subtree the order relation is the same. thus, * use the leftmost leaves as representatives. * * 2) if the order is reversed we must swap the * subtrees at the parent. */ for (k = 0; k < n; k++) /* reverse mapping of optimal order */ r[o[k]] = k; for (k = 0; k < n-1; k++) { if (left[k] > 0) /* left leaf in left subtree */ i = l[left[k]-1]; else i = -left[k]-1; if (right[k] > 0) /* left leaf in right subtree */ j = l[right[k]-1]; else j = -right[k]-1; if (r[i] > r[j]) { /* swap the subtrees */ h = right[k]; right[k] = left[k]; left[k] = h; } l[k] = i; /* left leaf in parent tree */ } for (k = 0; k < n; k++) /* offset to R indexing */ o[k]++; if (debug) { i = e[a+a*n]; j = e[b+b*n]; if (i > j) x[j+i*n] = z; else x[i+j*n] = z; for (k = 0; k < n-1; k++) { if (left[k] > 0) l[k] = l[left[k]-1]; else l[k] = -left[k]-1; if (right[k] > 0) r[k] = r[right[k]-1]; else r[k] = -right[k]-1; i = l[k]; j = r[k]; if (i > j) z = x[j+i*n]; else z = x[i+j*n]; // left and right are int // k, i and j are R_xlen_t which is typedefed to ptrdiff_t so we cast to int Rprintf(" %3i | %4i %4i | %3i %3i | %f\n", (int) k+1, left[k], right[k], (int) i+1, (int) j+1, z); } } Free(x); Free(l); Free(r); Free(c); Free(e); PutRNGstate(); UNPROTECT(1); return R_obj; } /**/ seriation/src/init.c0000644000176200001440000000573014457364117014166 0ustar liggesusers#include #include #include // for NULL #include /* .Call calls */ extern SEXP ar(SEXP, SEXP, SEXP); extern SEXP bar(SEXP, SEXP, SEXP); extern SEXP gradient(SEXP, SEXP, SEXP); extern SEXP inertia_criterion(SEXP, SEXP); extern SEXP lazy_path_length(SEXP, SEXP); extern SEXP least_squares_criterion(SEXP, SEXP); //extern SEXP order_greedy(SEXP); extern SEXP order_length(SEXP, SEXP); extern SEXP order_optimal(SEXP, SEXP); extern SEXP pathdist_floyd(SEXP); extern SEXP reorder_dist(SEXP, SEXP); extern SEXP rgar(SEXP, SEXP, SEXP, SEXP); extern SEXP stress(SEXP, SEXP, SEXP, SEXP); extern void isMon(void *, void *, void *, void *); extern void permNext(void *, void *); /* .Fortran calls */ extern void F77_NAME(arsa)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(bburcg)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(bbwrcg)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(cbea)(void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(rbea)(void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(energy)(void *, void *, void *, void *); static const R_CallMethodDef CallEntries[] = { {"ar", (DL_FUNC) &ar, 3}, {"bar", (DL_FUNC) &bar, 3}, {"gradient", (DL_FUNC) &gradient, 3}, {"inertia_criterion", (DL_FUNC) &inertia_criterion, 2}, {"lazy_path_length", (DL_FUNC) &lazy_path_length, 2}, {"least_squares_criterion", (DL_FUNC) &least_squares_criterion, 2}, // {"order_greedy", (DL_FUNC) &order_greedy, 1}, {"order_length", (DL_FUNC) &order_length, 2}, {"order_optimal", (DL_FUNC) &order_optimal, 2}, {"pathdist_floyd", (DL_FUNC) &pathdist_floyd, 1}, {"reorder_dist", (DL_FUNC) &reorder_dist, 2}, {"rgar", (DL_FUNC) &rgar, 4}, {"stress", (DL_FUNC) &stress, 4}, {NULL, NULL, 0} }; static const R_CMethodDef CEntries[] = { {"isMon", (DL_FUNC) &isMon, 4}, {"permNext", (DL_FUNC) &permNext, 2}, {NULL, NULL, 0} }; static const R_FortranMethodDef FortranEntries[] = { {"arsa", (DL_FUNC) &F77_NAME(arsa), 15}, {"bburcg", (DL_FUNC) &F77_NAME(bburcg), 10}, {"bbwrcg", (DL_FUNC) &F77_NAME(bbwrcg), 10}, {"cbea", (DL_FUNC) &F77_NAME(cbea), 7}, {"rbea", (DL_FUNC) &F77_NAME(rbea), 7}, {"energy", (DL_FUNC) &F77_NAME(energy), 4}, {NULL, NULL, 0} }; void R_init_seriation(DllInfo *dll) { R_registerRoutines(dll, CEntries, CallEntries, FortranEntries, NULL); R_useDynamicSymbols(dll, FALSE); } seriation/src/RNG_wrapper.c0000644000176200001440000000052012606356654015402 0ustar liggesusers/* FORTRAN Wrapper for R RNG */ #include void F77_SUB(getrngstate)(void) { GetRNGstate(); } void F77_SUB(putrngstate)(void) { PutRNGstate(); } /* Note: R's unif_rand returns 0<=x<=1 while FORTRAN's RAND returns 0<=x<1 */ void F77_SUB(unifrand)(float* x) { do{ *x = (float) unif_rand(); }while(*x >= 1.0 || *x <0.0); } seriation/src/criterion.c0000644000176200001440000002050414352615745015215 0ustar liggesusers/* * seriation - Infrastructure for seriation * Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik * * 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 2 of the License, or * 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, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. */ #include #include #include #include #include #include "lt.h" /* * path length can be found in optimal.c */ /* * least-squares criterion */ SEXP least_squares_criterion(SEXP R_dist, SEXP R_order) { double sum = 0.0; int p = INTEGER(getAttrib(R_dist, install("Size")))[0]; int *o = INTEGER(R_order); double *dist = REAL(R_dist); double x = 0.0; SEXP R_out; /* since d is symmetric we only need to sum up half the matrix */ for (int i = 1; i <= p; i++) { for (int j = 1; j < i; j++) { x = (dist[LT_POS(p, o[i-1], o[j-1])] - abs(i-j)); sum += x*x; } } sum *= 2.0; PROTECT(R_out = allocVector(REALSXP, 1)); REAL(R_out)[0] = sum; UNPROTECT(1); return(R_out); } /* * inertia criterion */ SEXP inertia_criterion(SEXP R_dist, SEXP R_order) { double sum = 0.0; int p = INTEGER(getAttrib(R_dist, install("Size")))[0]; int *o = INTEGER(R_order); double *dist = REAL(R_dist); int x = 0; SEXP R_out; /* since d ist symmetric we only need to sum up half the matrix */ for (int i = 1; i <= p; i++) { for (int j = 1; j < i; j++) { x = abs(i-j); sum += dist[LT_POS(p, o[i-1], o[j-1])] * x*x; } } sum *= 2.0; PROTECT(R_out = allocVector(REALSXP, 1)); REAL(R_out)[0] = sum; UNPROTECT(1); return(R_out); } /* * Anti-Robinson Events */ SEXP ar(SEXP R_dist, SEXP R_order, SEXP R_which) { /* * which indicates the weighing scheme * 1 ... no weighting (i) * 2 ... abs. deviations (s) * 3 ... weighted abs. deviations (w) */ int p = INTEGER(getAttrib(R_dist, install("Size")))[0]; int *o = INTEGER(R_order); double *dist = REAL(R_dist); int which = INTEGER(R_which)[0]; double sum = 0.0; double d_ij = 0.0; double d_ik = 0.0; SEXP R_out; /* sum_i=1^p sum_j d_ik) * weight */ for (int i = 1; i < (p-1); i++) { for(int j = i+1; j < p; j++) { d_ij = dist[LT_POS(p, o[i-1], o[j-1])]; for(int k = j+1; k <= p; k++) { d_ik = dist[LT_POS(p, o[i-1], o[k-1])]; if(d_ij > d_ik) { if(which == 1) { sum++; }else if(which == 2) { sum += fabs(d_ij - d_ik); }else if(which == 3) sum += abs(o[j-1]-o[k-1]) * fabs(d_ij - d_ik); } } } } PROTECT(R_out = allocVector(REALSXP, 1)); REAL(R_out)[0] = sum; UNPROTECT(1); return(R_out); } /* * Relative Generalized Anti-Robinson Events */ SEXP rgar(SEXP R_dist, SEXP R_order, SEXP R_w, SEXP R_relative) { int n = INTEGER(getAttrib(R_dist, install("Size")))[0]; int *o = INTEGER(R_order); int relative = INTEGER(R_relative)[0]; double *dist = REAL(R_dist); /* w is in [2, n-1] (window size) */ int w = INTEGER(R_w)[0]; double d_ij = 0.0; double d_ik = 0.0; int ar = 0; /* AR events */ int total = 0; /* total number of possible AR events */ int i, j, k; SEXP R_out; /* sum_i=1^n sum_{(i-w)<=j d_ik) * weight */ for (i = 1; i <= (n-2); i++) { /* Rprintf("i2=%d\n", i); */ for(j = i+1; j <= MIN(i+w-1, n-1); j++) { /* Rprintf("j2=%d\n", j); */ d_ij = dist[LT_POS(n, o[i-1], o[j-1])]; for(k = j+1; k <= MIN(i+w, n); k++) { /* Rprintf("k2=%d\n\n", k); */ d_ik = dist[LT_POS(n, o[i-1], o[k-1])]; total++; if(d_ij > d_ik) ar++; } } } /* Note: total = (2/3-n)*w + n*w^2 - 2/3*w^3 */ PROTECT(R_out = allocVector(REALSXP, 1)); if(relative) REAL(R_out)[0] = (double) ar / (double) total; else REAL(R_out)[0] = (double) ar; UNPROTECT(1); return(R_out); } /* * Gradient Measure */ SEXP gradient(SEXP R_dist, SEXP R_order, SEXP R_which) { /* * which indicates the weighing scheme * 1 ... no weighting * 2 ... weighted */ int p = INTEGER(getAttrib(R_dist, install("Size")))[0]; int *o = INTEGER(R_order); double *dist = REAL(R_dist); int which = INTEGER(R_which)[0]; double sum = 0.0; double d_ij = 0.0; double d_ik = 0.0; double d_kj = 0.0; double diff; SEXP R_out; int i, k, j; /* sum_i 1) { /* weighted */ sum += diff; }else{ /* unweighted */ if(diff > 0) sum += 1.0; else if(diff < 0) sum -= 1.0; } /* second sum */ d_kj = dist[LT_POS(p, o[k-1], o[j-1])]; /* diff = d_kj - d_ij; seems to be wrong in the book*/ diff = d_ij - d_kj; if(which > 1) { /* weighted */ sum += diff; }else{ /* unweighted */ if(diff > 0) sum += 1.0; else if(diff < 0) sum -= 1.0; } } } } PROTECT(R_out = allocVector(REALSXP, 1)); REAL(R_out)[0] = sum; UNPROTECT(1); return(R_out); } /* * Lazy Path length (see Earle and Hurley 2015) */ SEXP lazy_path_length(SEXP R_dist, SEXP R_order) { double tour_length = 0.0; SEXP R_tour_length; double segment; bool posinf = false; bool neginf = false; int *order = INTEGER(R_order); int n = INTEGER(getAttrib(R_dist, install("Size")))[0]; double *dist = REAL(R_dist); if (n != LENGTH(R_order)) error("length of distance matrix and tour do not match"); for (int i = 1; i <= n-1; i++) { segment = dist[LT_POS(n, order[i-1], order[i])]; // check Inf if (segment == R_PosInf) posinf = true; else if (segment == R_NegInf) neginf = true; else tour_length += (n-i) * segment; } // do not close tour! // inf if (posinf && neginf) tour_length = NA_REAL; else if (posinf) tour_length = R_PosInf; else if (neginf) tour_length = R_NegInf; // create R object PROTECT(R_tour_length = NEW_NUMERIC(1)); REAL(R_tour_length)[0] = tour_length; UNPROTECT(1); return R_tour_length; } /* * Banded Anti-Robinson Form (see Earle and Hurley, 2015) */ SEXP bar(SEXP R_dist, SEXP R_order, SEXP R_b) { int n = INTEGER(getAttrib(R_dist, install("Size")))[0]; int *o = INTEGER(R_order); double *dist = REAL(R_dist); /* 1 <= b < n */ int b = INTEGER(R_b)[0]; double ar = 0; int i, j; SEXP R_out; /* sum_{|i-j|<=b} (b+1-|i-j|) d_{ij} */ for (i = 1; i <= n-1; i++) { for (j = i+1; j <= MIN(i+b, n); j++) { ar += (b+1-abs(i-j)) * dist[LT_POS(n, o[i-1], o[j-1])]; } } // create R object PROTECT(R_out = NEW_NUMERIC(1)); REAL(R_out)[0] = ar; UNPROTECT(1); return R_out; } seriation/src/stress.c0000644000176200001440000002173414313070703014532 0ustar liggesusers/* * seriation - Infrastructure for seriation * Copyrigth (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik * * 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 2 of the License, or * 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, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. */ #include #include /* compute the stress measure based on Moor Neighborhoods, i.e. the * sums of the squared distances of a point to its eight (five at the * margins and three at the corners) adjacent neighbors as defined by * the row and column indexes (or subsets of it). * * this function counts each edge distance only once! so, if you * prefer the measure from the paper you have to take twice the * value. * * note that NAs are omitted. however, the function does not return * NA if there was no legal edge at all. */ double stressMoore(double *x, int *r, int *c, int nr, int nc, int nrx) { double d, v, z; R_xlen_t i, j, l, ll, k, kk; z = 0; l = r[0]; for (i = 0; i < nr-1; i++) { ll = r[i+1]; k = c[0] * nrx; for (j = 0; j < nc-1; j++) { kk = c[j+1] * nrx; v = x[l+k]; if (!ISNAN(v)) { d = v - x[ll+k]; if (!ISNAN(d)) z += d * d; d = v - x[ll+kk]; if (!ISNAN(d)) z += d * d; d = v - x[l+kk]; if (!ISNAN(d)) z += d * d; } d = x[ll+k] - x[l+kk]; k = kk; if (!ISNAN(d)) z += d * d; } d = x[l+k] - x[ll+k]; l = ll; if (!ISNAN(d)) z += d * d; R_CheckUserInterrupt(); } k = c[0] * nrx; for (j = 0; j < nc-1; j++) { kk = c[j+1] * nrx; d = x[l+k] - x[l+kk]; k = kk; if (!ISNAN(d)) z += d * d; } return z; } /* same as above but use a von Neumann neighborhood, i.e. the * neighboring points on the diagonals are excluded. */ double stressNeumann(double *x, int *r, int *c, int nr, int nc, int nrx) { double d, v, z; R_xlen_t i, j, l, ll, k, kk; z = 0; l = r[0]; for (i = 0; i < nr-1; i++) { ll = r[i+1]; k = c[0] * nrx; for (j = 0; j < nc-1; j++) { kk = c[j+1] * nrx; v = x[l+k]; if (!ISNAN(v)) { d = v - x[ll+k]; if (!ISNAN(d)) z += d * d; d = v - x[l+kk]; if (!ISNAN(d)) z += d * d; } k = kk; } d = x[l+k] - x[ll+k]; l = ll; if (!ISNAN(d)) z += d * d; R_CheckUserInterrupt(); } k = c[0] * nrx; for (j = 0; j < nc-1; j++) { kk = c[j+1] * nrx; d = x[l+k] - x[l+kk]; k = kk; if (!ISNAN(d)) z += d * d; } return z; } /* R wrapper to the stress functions */ SEXP stress(SEXP R_x, SEXP R_r, SEXP R_c, SEXP R_type) { int nrx, nr, nc; R_xlen_t k; int *r, *c; SEXP R_obj; /* Translation form character to int index not needed * R part makes sure it is int! PROTECT(R_r = arraySubscript(0, R_r, GET_DIM(R_x), getAttrib, (STRING_ELT), R_x)); PROTECT(R_c = arraySubscript(1, R_c, GET_DIM(R_x), getAttrib, (STRING_ELT), R_x)); */ nrx = INTEGER(GET_DIM(R_x))[0]; /* number of rows */ nr = LENGTH(R_r); nc = LENGTH(R_c); /* remap R indexes to C indexes * this sucks! */ r = Calloc(nr, int); c = Calloc(nc, int); /* copy and shift indexes */ for (k = 0; k < nr; k++) r[k] = INTEGER(R_r)[k]-1; for (k = 0; k < nc; k++) c[k] = INTEGER(R_c)[k]-1; PROTECT(R_obj = NEW_NUMERIC(1)); switch (INTEGER(R_type)[0]) { case 1: REAL(R_obj)[0] = stressMoore(REAL(R_x), r, c, nr, nc, nrx); break; case 2: REAL(R_obj)[0] = stressNeumann(REAL(R_x), r, c, nr, nc, nrx); break; default: Free(r); Free(c); error("stress: type not implemented"); } Free(r); Free(c); /* UNPROTECT(3); */ UNPROTECT(1); return R_obj; } /* NOTE: currently unused */ /* calculate the Moore distances between all pairs of rows or columns. * of a matrix. for a given (fixed) row or column ordering the distances * could be used to search for an optimal column or row ordering using * an alternating scheme. * * if the calculation are over the rows ncx = 1, otherwise the roles * of rows and columns are swapped and nrx = 1. * * the caller must provide the result array d and the temporary array t. * * the distances are arranged in lower triangular column format (compare * the R function dist). * * note that the edge distances are computed only once! * * (C) ceeboo 2005, 2006 */ void distMoore(double *x, int *r, int *c, int nr, int nc, int nrx, int ncx, double *d, double *t) { double v, w, z; R_xlen_t i, ii, j, jj, k, kk, kkk, l; for (k = 0; k < nr*(nr-1)/2; k++) /* initialize distances */ d[k] = 0; for (i = 0; i < nr; i++) { z = 0; ii = r[i] * ncx; kk = c[0] * nrx; for (k = 0; k < nc-1; k++) { kkk = c[k+1] * nrx; w = x[ii+kk] - x[ii+kkk]; if (!ISNAN(w)) z += w * w; kk = kkk; } t[i] = z; R_CheckUserInterrupt(); } l = 0; for (i = 0; i < nr-1; i++) { ii = r[i] * ncx; for (j = i+1; j < nr; j++) { z = t[i] + t[j]; jj = r[j] * ncx; kk = c[0] * nrx; for (k = 0; k < nc-1; k++) { kkk = c[k+1] * nrx; v = x[ii+kk]; if (!ISNAN(v)) { w = v - x[jj+kk]; if (!ISNAN(w)) z += w * w; w = v - x[jj+kkk]; if (!ISNAN(w)) z += w * w; } w = x[jj+kk] - x[ii+kkk]; if (!ISNAN(w)) z += w * w; kk = kkk; } w = x[ii+kk] - x[jj+kk]; if (!ISNAN(w)) z += w * w; d[l++] = z; R_CheckUserInterrupt(); } } } /* calculate the von Neumann distances over the rows or columns of a * matrix. * * compare above. */ void distNeumann(double *x, int *r, int *c, int nr, int nc, int nrx, int ncx, double *d, double *t) { double w, z; R_xlen_t i, ii, j, jj, k, kk, kkk, l; for (k = 0; k < nr*(nr-1)/2; k++) /* initialize distances */ d[k] = 0; for (i = 0; i < nr; i++) { z = 0; ii = r[i] * ncx; kk = c[0] * nrx; for (k = 0; k < nc-1; k++) { kkk = c[k+1] * nrx; w = x[ii+kk] - x[ii+kkk]; if (!ISNAN(w)) z += w * w; kk = kkk; } t[i] = z; R_CheckUserInterrupt(); } l = 0; for (i = 0; i < nr-1; i++) { ii = r[i] * ncx; for (j = i+1; j < nr; j++) { z = t[i] + t[j]; jj = r[j] * ncx; for (k = 0; k < nc-1; k++) { kk = c[k] * nrx; w = x[ii+kk]- x[jj+kk]; if (!ISNAN(w)) z += w * w; } kk = c[k] * nrx; w = x[ii+kk] - x[jj+kk]; if (!ISNAN(w)) z += w * w; d[l++] = z; R_CheckUserInterrupt(); } } } /* R wrapper */ SEXP stress_dist(SEXP R_x, SEXP R_r, SEXP R_c, SEXP R_bycol, SEXP R_type) { int nrx, nr, nc; R_xlen_t k; int *r, *c; double *d, *t; SEXP R_obj = R_NilValue; /* compiler hack */ /* Translation form character to int index not needed * R part makes sure it is int! PROTECT(R_r = arraySubscript(0, R_r, GET_DIM(R_x), getAttrib, (STRING_ELT), R_x)); PROTECT(R_c = arraySubscript(1, R_c, GET_DIM(R_x), getAttrib, (STRING_ELT), R_x)); */ nrx = INTEGER(GET_DIM(R_x))[0]; /* number of rows */ nr = LENGTH(R_r); nc = LENGTH(R_c); /* remap R indexes to C indexes * this sucks! */ r = Calloc(nr, int); c = Calloc(nc, int); /* copy and shift indexes */ for (k = 0; k < nr; k++) r[k] = INTEGER(R_r)[k]-1; for (k = 0; k < nc; k++) c[k] = INTEGER(R_c)[k]-1; switch(LOGICAL(R_bycol)[0]) { case 0: PROTECT(R_obj = NEW_NUMERIC(nr*(nr-1)/2)); d = REAL(R_obj); t = Calloc(nr, double); switch(INTEGER(R_type)[0]) { case 1: distMoore(REAL(R_x), r, c, nr, nc, nrx, 1, d, t); break; case 2: distNeumann(REAL(R_x), r, c, nr, nc, nrx, 1, d, t); break; default: Free(r); Free(c); Free(t); error("stress_dist: \"type\" not implemented"); } Free(t); break; case 1: PROTECT(R_obj = NEW_NUMERIC(nc*(nc-1)/2)); d = REAL(R_obj); t = Calloc(nc, double); switch(INTEGER(R_type)[0]) { case 1: distMoore(REAL(R_x), c, r, nc, nr, 1, nrx, d, t); break; case 2: distNeumann(REAL(R_x), c, r, nc, nr, 1, nrx, d, t); break; default: Free(r); Free(c); Free(t); error("stress_dist: type not implemented"); } Free(t); break; default: Free(r); Free(c); error("stress_dist: \"bycol\" invalid"); } Free(r); Free(c); /* UNPROTECT(3); */ UNPROTECT(1); return R_obj; } seriation/src/bbwrcg.f0000644000176200001440000003043414452316640014464 0ustar liggesusersC ANTI-ROBINSON SERIATION C branch-and-bound C by Brusco, and Stahl, S. C R Interface by Michael Hahsler C PROGRAM DYNAMIC C SUBROUTINE dynamic(N, A, EPS, X) SUBROUTINE bbwrcg(N, A, EPS, X, Q, D, DD, S, UNSEL, IVERB) IMPLICIT INTEGER(A-Z) C DOUBLE PRECISION TIMEA,TIMEB,TIMTOT,A(50,50),EPS DOUBLE PRECISION EPS, A(N,N), D(N,N,N), 1 DD(N,N,N),ZBEST,Z,ACT,DELTA,ZBD,IDX1,IDX2 REAL S1 INTEGER X(N),Q(N),S(N),UNSEL(N) C EPS is unused this is to supress the warning. EPS = 1.0d-07 C Initialize R RNG CALL getrngstate() OLDM=0 CHECKS=0 C C ################################################################# C 10/13/01 This program fits an "weighted" row gradient criterion C to a symmetric proximity matrix. Count +1 if the anti- C Robinson triple is satisfied, -1 if its not, and 0 for C ties. Only look at upper half of matrix C 07/20/02: Improved symmetry test implemented. C 07/26/03: Fixed the incorrect symmetry test, added an interchange test C avoid use of so many "IF" statements using F & D matrices C 12/24/03: Add insertion test to interchange test. C 07/09/15: Fixed memory issue (MFH) C ################################################################# C C OPEN(1,FILE='AMAT.DAT') ! Dissimilarity matrix C OPEN(2,FILE='SEQ.OUT') ! Output file C EPS = 1.0d-07 C READ(1,*) N ! Read number of objects C WRITE(*,*) 'TYPE 1 FOR HALF MATRIX OR TYPE 2 FOR FULL MATRIX' C READ(*,*) ITYPE C ITYPE = 2 C IF(ITYPE.EQ.2) THEN C READ(1,*) ((A(I,J),J=1,N),I=1,N) C ELSE C DO J = 2,N C READ(1,*) (A(I,J),I=1,J-1) C END DO C DO J = 2,N C DO I = 1,J-1 C A(J,I) = A(I,J) C END DO C END DO C END IF C CALL GETTIM (IHR, IMIN, ISEC, I100) C CALL GETDAT (IYR, IMON, IDAY) C TIMEA=DFLOAT(86400*IDAY+3600*IHR+60*IMIN+ISEC)+DFLOAT(I100)/100. DO I = 1,N A(I,I) = 0.0D0 END DO C DO 848 I = 1,N DO 849 J = 1,N IF(I.EQ.J) GO TO 849 DO 850 K = 1,N IF(I.EQ.K.OR.J.EQ.K) GO TO 850 C bbwrg C D(I,J,K) = A(I,K) - A(I,J) D(I,J,K) = 2.*A(I,K) - A(I,J) - A(J,K) 850 CONTINUE 849 CONTINUE 848 CONTINUE C DO 851 I = 1,N DO 852 J = 1,N IF(I.EQ.J) GO TO 852 DO 853 K = 1,N IF(I.EQ.K.OR.J.EQ.K) GO TO 853 ACT=D(I,J,K) IF(D(I,K,J).GT.ACT) ACT = D(I,K,J) IF(D(J,I,K).GT.ACT) ACT = D(J,I,K) DD(I,J,K) = ACT 853 CONTINUE 852 CONTINUE 851 CONTINUE C Run heuristic to find a good objective value IF (IVERB == 1) THEN CALL intpr('Run heuristic', -1, IVERB, 0) ENDIF ZBEST = 0.0D0 C DO 3500 JJJ = 1,100 DO 3500 JJJ = 1,100 DO I = 1,N UNSEL(I) = I Q(I) = 0 END DO NNSEL = N C 3501 CALL RANDOM(S1) C 3501 S1 = rand() 3501 CALL unifrand(S1) ISEL = INT(1. + S1*FLOAT(NNSEL)) IF(ISEL.GT.NNSEL) ISEL = NNSEL Q(NNSEL) = UNSEL(ISEL) DO J = ISEL,NNSEL-1 UNSEL(J) = UNSEL(J+1) END DO NNSEL = NNSEL - 1 IF(NNSEL.GT.0) GO TO 3501 C WRITE(*,72) (Q(J),J=1,N) C 72 FORMAT(20I3) Z = 0.0D0 DO I = 1,N-2 R1 = Q(I) DO J = I+1,N-1 R2 = Q(J) DO K = J+1,N R3 = Q(K) Z = Z + D(R1,R2,R3) END DO END DO END DO 3502 ITRIG = 0 DO II = 1,N-1 DO JJ = II+1,N C R interrupt CALL rchkusr() C R3 = Q(JJ) R2 = Q(II) DELTA=0.0D0 DO I = 1,II-1 R1 = Q(I) DELTA = DELTA + D(R1,R3,R2) - D(R1,R2,R3) DO J = II+1,JJ-1 R4 = Q(J) DELTA = DELTA + D(R1,R3,R4) - D(R1,R2,R4) DELTA = DELTA + D(R1,R4,R2) - D(R1,R4,R3) END DO END DO DO J = II+1,JJ-1 R4 = Q(J) DELTA = DELTA + D(R3,R4,R2) - D(R2,R4,R3) DO K = JJ+1,N R5 = Q(K) DELTA = DELTA + D(R4,R2,R5) - D(R4,R3,R5) DELTA = DELTA + D(R3,R4,R5) - D(R2,R4,R5) END DO END DO DO K = JJ + 1,N R5 = Q(K) DELTA = DELTA + D(R3,R2,R5) - D(R2,R3,R5) END DO DO I = II+1,JJ-2 DO J = I+1,JJ-1 R4A = Q(I) R4B = Q(J) DELTA = DELTA + D(R4A,R4B,R2) - D(R4A,R4B,R3) DELTA = DELTA + D(R3,R4A,R4B) - D(R2,R4A,R4B) END DO END DO IF(DELTA.GT.0) THEN Z = Z + DELTA Q(II) = R3 Q(JJ) = R2 ITRIG = 1 END IF END DO END DO IF(ITRIG.EQ.1) GO TO 3502 IF(Z.GT.ZBEST) ZBEST = Z 3500 CONTINUE C WRITE(2,3505) ZBEST IF (IVERB == 1) THEN C WRITE(*,3505) ZBEST CALL dblepr('HEURISTIC OBJ VALUE', -1, DBLE(ZBEST), 1) ENDIF C 3505 FORMAT(' HEURISTIC OBJ VALUE ',F20.4) Z = ZBEST-1 DO I = 1,N Q(I) = 0 END DO C M=1 Q(M)=1 S(1)=1 trig=1 DO K = 2,N Q(K)=0 END DO C 1 M = M + 1 C C CHECKS=CHECKS+1 IF (IVERB == 1 .AND. M .GT. OLDM) THEN C WRITE (*,6000) M+1, CHECKS CALL intpr('reached position', -1, M+1, 1) CALL intpr('with following number of checks', -1, CHECKS, 1) C 6000 FORMAT('reached position ', I5, ' with ', I9, ' checks') OLDM=M ENDIF C C R interrupt CALL rchkusr() C C main loop C 2 Q(M)=Q(M)+1 C C MFH: Make sure to not get out of bounds with S(Q(M)) - 7/9/15 IF(Q(M).GT.N) GO TO 222 IF(S(Q(M)).EQ.1) GO TO 2 ! REDUNDANCY 222 IF(M.EQ.1.AND.Q(M).GT.N) GO TO 9 ! TERMINATE IF(M.GT.1.AND.Q(M).GT.N) GO TO 7 ! GO TO RETRACTION C only for bbwrcg IF(TRIG.EQ.0.AND.Q(M).EQ.2) GO TO 2 ! SYMMETRY FATHOM C S(Q(M))=1 IF(M.EQ.1) GO TO 1 IF(M.EQ.N-1) THEN CALL EVALBBWRCG(ZBD,Q,N,D) IF(ZBD.GT.Z) THEN Z=ZBD IF (IVERB == 1) THEN C WRITE(*,*) 'Eval =',z CALL dblepr('Eval', -1, DBLE(z), 1) ENDIF DO I = 1,N X(I)=Q(I) END DO END IF Q(N)=0 S(Q(M))=0 GO TO 2 ELSE DO 251 MM = M-1,1,-1 ! Insertion Test R3=Q(M) IDX1=0 IDX2=0 DO I = 1,MM-1 R1=Q(I) DO J = MM,M-1 R4=Q(J) IDX1=IDX1+D(R1,R4,R3) IDX2=IDX2+D(R1,R3,R4) C END DO C END DO C DO 250 I = 1,N IF(S(I).EQ.1) GO TO 250 R5=I C DO J = MM,M-1 R4=Q(J) IDX1=IDX1+D(R4,R3,R5) IDX2=IDX2+D(R3,R4,R5) END DO C 250 CONTINUE C DO J = MM, M-2 DO JJ = J+1, M-1 R4A=Q(J) R4B=Q(JJ) IDX1=IDX1+D(R4A,R4B,R3) IDX2=IDX2+D(R3,R4A,R4B) END DO END DO IF(IDX1.LT.IDX2) THEN S(Q(M))=0 C ism2 = ism2 + 1 GO TO 2 END IF 251 CONTINUE C go to 253 C DO 151 MM = M-2,1,-1 ! Interchange Test R3=Q(M) R2=Q(MM) IDX1=0 IDX2=0 DO J = MM+1,M-1 R4 = Q(J) IDX1=IDX1+D(R2,R4,R3) IDX2=IDX2+D(R3,R4,R2) END DO DO I = 1,MM-1 R1=Q(I) IDX1=IDX1+D(R1,R2,R3) IDX2=IDX2+D(R1,R3,R2) DO J = MM+1,M-1 R4=Q(J) IDX1=IDX1+D(R1,R2,R4) IDX2=IDX2+D(R1,R3,R4) C IDX1=IDX1+D(R1,R4,R3) IDX2=IDX2+D(R1,R4,R2) C END DO C END DO C DO 150 I = 1,N IF(S(I).EQ.1) GO TO 150 R5=I IDX1=IDX1+D(R2,R3,R5) IDX2=IDX2+D(R3,R2,R5) C DO J = MM+1,M-1 R4=Q(J) IDX1=IDX1+D(R2,R4,R5) IDX2=IDX2+D(R3,R4,R5) C IDX1=IDX1+D(R4,R3,R5) IDX2=IDX2+D(R4,R2,R5) END DO C 150 CONTINUE C DO J = MM+1, M-2 DO JJ = J+1, M-1 R4A=Q(J) R4B=Q(JJ) IDX1=IDX1+D(R4A,R4B,R3) IDX2=IDX2+D(R4A,R4B,R2) IDX1=IDX1+D(R2,R4A,R4B) IDX2=IDX2+D(R3,R4A,R4B) END DO END DO IF(IDX1.LT.IDX2) THEN C ism = ism + 1 S(Q(M))=0 GO TO 2 END IF 151 CONTINUE C CALL BOUND2BBWRCG(ZBD,N,Q,M,D,S,DD) IF(ZBD.LE.Z) THEN S(Q(M))=0 C ism3 = ism3 + 1 GO TO 2 END IF IF(Q(M).EQ.1) TRIG=1 GO TO 1 END IF C 7 IF(Q(M).EQ.1) TRIG=0 C MFH: Make sure to not get out of bounds with S(Q(M)) - 6/9/15 IF(Q(M).GT.N) GO TO 777 S(Q(M))=0 777 Q(M)=0 M=M-1 IF(Q(M).EQ.1) TRIG=0 S(Q(M))=0 C C WRITE(*,*) 'X',(X(J),J=1,N) C WRITE(*,*) 'Q',(Q(J),J=1,N) C GO TO 2 C 9 CALL GETTIM (IHR, IMIN, ISEC, I100) C CALL GETDAT (IYR, IMON, IDAY) C TIMEB=DFLOAT(86400*IDAY+3600*IHR+60*IMIN+ISEC)+DFLOAT(I100)/100. C TIMTOT=TIMEB-TIMEA C write(*,*) ism,ism2,ism3 C WRITE(*,69) Z,TIMTOT C 9 WRITE(*,69) Z C WRITE(2,69) Z,TIMTOT C WRITE(2,70) (X(I),I=1,N) C 69 FORMAT(' MAXIMUM UNWEIGHTED ROW GRADIENT INDEX ',I20) C 69 FORMAT(' MAXIMUM UNWEIGHTED ROW GRADIENT INDEX ',I7,' CPU TIME ', C 1 F8.2) C 70 FORMAT(30I3) C 9 IF (IVERB == 1) THEN C PRINT *, 'total number of checks: ', CHECKS CALL intpr('total number of checks', -1, CHECKS, 1) ENDIF C Return R RNG CALL Putrngstate() RETURN END C SUBROUTINE BOUND2BBWRCG(ZBD,N,Q,M,D,S,DD) IMPLICIT INTEGER(A-Z) DOUBLE PRECISION D(N,N,N),ZBD,DD(N,N,N),Z1,Z2,Z3,ZA,ZB, 1 ZCT,N4 C ACT is now unused INTEGER Q(N),S(N) Z1=0 DO I = 1,M-2 R1=Q(I) DO J = I+1,M-1 R2=Q(J) DO K = J+1,M R3=Q(K) Z1=Z1+D(R1,R2,R3) END DO END DO END DO C Z2=0 DO I = 1,M-1 R1=Q(I) DO J = I+1,M R2=Q(J) DO 60 K = 1,N IF(S(K).EQ.1) GO TO 60 R3=K Z2=Z2+D(R1,R2,R3) 60 CONTINUE END DO END DO C Z3=0 DO 90 I = 1,N-1 IF(S(I).EQ.1) GO TO 90 R2=I DO 91 J = I+1,N IF(S(J).EQ.1) GO TO 91 R3=J ZA=0 ZB=0 DO 92 K = 1,M R1=Q(K) ZA=ZA+D(R1,R2,R3) ZB=ZB+D(R1,R3,R2) 92 CONTINUE ZCT=ZA IF(ZB.GT.ZCT) ZCT=ZB Z3=Z3+ZCT 91 CONTINUE 90 CONTINUE C N4=0 DO 93 I = 1,N-2 IF(S(I).EQ.1) GO TO 93 R1=I DO 94 J = I+1,N-1 IF(S(J).EQ.1) GO TO 94 DO 95 K = J+1,N IF(S(K).EQ.1) GO TO 95 C ACT=D(I,J,K) C IF(D(I,K,J).GT.ACT) ACT=D(I,K,J) C IF(D(J,I,K).GT.ACT) ACT=D(J,I,K) C N4=N4+ACT N4 = N4 + DD(I,J,K) 95 CONTINUE 94 CONTINUE 93 CONTINUE C N1=N*(N-1)*(N-2)/3 ! This bound is OK! The N1 is total C N2=M*(M-1)*(M-2)/3 ! and N2 and N3 are truly computed terms. C N3=(N-M)*(M*(M-1)) ! So N1-N2-N3 assumes +1 for rest, which ZBD=Z1+Z2+Z3+n4 ! (N-M)*(N-M-1)*(N-M-2)/3 +n4 C WRITE(*,98) N,M,N1,N2,N3,Z1,Z2,N1-N2-N3,ZBD C 98 FORMAT(9I7) RETURN END C SUBROUTINE EVALBBWRCG(ZBD,Q,N,D) IMPLICIT INTEGER(A-Z) DOUBLE PRECISION D(N,N,N),ZBD INTEGER Q(N) ZBD=0 DO 85 I = 1,N DO J = 1,N-1 IF(Q(J).EQ.I) GO TO 85 END DO Q(N)=I 85 CONTINUE DO I = 1,N-2 R1=Q(I) DO J = I+1,N-1 R2=Q(J) DO K = J+1,N R3=Q(K) ZBD=ZBD+D(R1,R2,R3) END DO END DO END DO RETURN END seriation/src/lt.h0000644000176200001440000000125614313070703013630 0ustar liggesusers/* LT_POS to access a lower triangle matrix by C. Buchta * modified by M. Hahsler * n ... number of rows/columns * i,j ... column and row index (starts with 1) */ /* R_xlen_t is for long vector support */ #ifndef LT_POS #define LT_POS(n, i, j) \ (i)==(j) ? 0 : (i)<(j) ? (R_xlen_t)(n) * ((i) - 1) - (R_xlen_t)(i)*((i)-1)/2 + (j)-(i) -1 \ : (R_xlen_t)(n)*((j)-1) - (R_xlen_t)(j)*((j)-1)/2 + (i)-(j) -1 #endif /* M_POS to access matrix column-major order by i and j index (starts with 1) */ #ifndef M_POS #define M_POS(n, i, j) ((i)+(R_xlen_t)(n)*(j)) #endif /* * MIN/MAX */ #define MIN(X,Y) ((X) < (Y) ? (X) : (Y)) #define MAX(X,Y) ((X) > (Y) ? (X) : (Y)) seriation/src/nextperm.c0000644000176200001440000000137214456276571015070 0ustar liggesusers#include void swap(double *, int, int); void permNext(double *, int *); void isMon(double *, double *, int *, int *); void swap(double *x, int i, int j) { float temp; temp = x[i]; x[i] = x[j]; x[j] = temp; } void permNext(double *x, int *nn) { int i, j, n = *nn; i = n - 1; while (x[i - 1] >= x[i]) i--; if (i == 0) return; j = n; while (x[j - 1] <= x[i - 1]) j--; swap(x, i - 1, j - 1); j = n; i++; while (i < j) { swap(x, i - 1, j - 1); j--; i++; } } void isMon(double *x, double *y, int *nn, int *what) { int n = *nn, i, j; for (i = 1; i < n; i++) for (j = 0; j < i; j++) if (((x[i] - x[j]) * (y[i] - y[j])) <= 0) *what = 0; } seriation/src/dist.c0000644000176200001440000000312514313070703014144 0ustar liggesusers/* * seriation - Infrastructure for seriation * Copyrigth (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik * * 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 2 of the License, or * 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, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. */ #include #include #include "lt.h" /* * Reorder a dist object with a given order * Beware: all checking and attribute stuff has to be done in the R wrapper */ SEXP reorder_dist(SEXP R_dist, SEXP R_order) { SEXP R_dist_out; int n = INTEGER(getAttrib(R_dist, install("Size")))[0]; R_xlen_t n_out = LENGTH(R_order); int *o = INTEGER(R_order); PROTECT(R_dist_out = allocVector(REALSXP, n_out*(n_out-1)/2)); double *dist = REAL(R_dist); double *dist_out = REAL(R_dist_out); for (int i = 1; i <= n_out; i++) { for (int j = (i+1); j <=n_out; j++) { if(o[i-1] == o[j-1]) dist_out[LT_POS(n_out, i, j)] = 0.0; else dist_out[LT_POS(n_out, i, j)] = dist[LT_POS(n, o[i-1], o[j-1])]; } } UNPROTECT(1); return R_dist_out; } seriation/src/bburcg.f0000644000176200001440000002702414452345444014467 0ustar liggesusersC ANTI-ROBINSON SERIATION C branch-and-bound C by Brusco, M. and Stahl, S. C R Interface by Michael Hahsler C PROGRAM DYNAMIC C SUBROUTINE dynamic(N, A, EPS, X) SUBROUTINE bburcg(N, A, EPS, X, Q, D, DD, S, UNSEL, IVERB) IMPLICIT INTEGER(A-Z) C DOUBLE PRECISION TIMEA,TIMEB,TIMTOT,A(50,50),EPS DOUBLE PRECISION A(N,N), EPS REAL S1 INTEGER X(N),Q(N),D(N,N,N),S(N),DD(N,N,N),UNSEL(N) C Initialize R RNG CALL getrngstate() OLDM=0 CHECKS=0 C C ################################################################# C 10/13/01 This program fits an "unweighted" row gradient criterion C to a symmetric proximity matrix. Count +1 if the anti- C Robinson triple is satisfied, -1 if its not, and 0 for C ties. Only look at upper half of matrix C 07/20/02: Improved symmetry test implemented. C 07/26/03: Fixed the incorrect symmetry test, added an interchange test C avoid use of so many "IF" statements using F & D matrices C 12/24/03: Add insertion test to interchange test. C 07/09/15: Fixed memory issue (MFH) C ################################################################# C C OPEN(1,FILE='AMAT.DAT') ! Dissimilarity matrix C OPEN(2,FILE='SEQ.OUT') ! Output file C EPS = 1.0d-07 C READ(1,*) N ! Read number of objects C WRITE(*,*) 'TYPE 1 FOR HALF MATRIX OR TYPE 2 FOR FULL MATRIX' C READ(*,*) ITYPE C ITYPE = 2 C IF(ITYPE.EQ.2) THEN C READ(1,*) ((A(I,J),J=1,N),I=1,N) C ELSE C DO J = 2,N C READ(1,*) (A(I,J),I=1,J-1) C END DO C DO J = 2,N C DO I = 1,J-1 C A(J,I) = A(I,J) C END DO C END DO C END IF C CALL GETTIM (IHR, IMIN, ISEC, I100) C CALL GETDAT (IYR, IMON, IDAY) C TIMEA=DBLE(86400*IDAY+3600*IHR+60*IMIN+ISEC)+DBLE(I100)/100. DO I = 1,N A(I,I) = 0.0D0 END DO C DO 848 I = 1,N DO 849 J = 1,N IF(I.EQ.J) GO TO 849 DO 850 K = 1,N IF(I.EQ.K.OR.J.EQ.K) GO TO 850 IF(A(I,K).GT.A(I,J)+EPS) D(I,J,K)=1 IF(A(I,K).LT.A(I,J)-EPS) D(I,J,K)=-1 C for bburcg IF(A(I,K).GT.A(J,K)+EPS) D(I,J,K)=D(I,J,K)+1 IF(A(I,K).LT.A(J,K)-EPS) D(I,J,K)=D(I,J,K)-1 C 850 CONTINUE 849 CONTINUE 848 CONTINUE C DO 851 I = 1,N DO 852 J = 1,N IF(I.EQ.J) GO TO 852 DO 853 K = 1,N IF(I.EQ.K.OR.J.EQ.K) GO TO 853 ACT=D(I,J,K) IF(D(I,K,J).GT.ACT) ACT = D(I,K,J) IF(D(J,I,K).GT.ACT) ACT = D(J,I,K) DD(I,J,K) = ACT 853 CONTINUE 852 CONTINUE 851 CONTINUE C ZBEST = 0 DO 3500 JJJ = 1,20 DO I = 1,N UNSEL(I) = I Q(I) = 0 END DO NNSEL = N C 3501 CALL RANDOM(S1) C 3501 S1 = rand() 3501 CALL unifrand(S1) ISEL = INT(1. + S1*FLOAT(NNSEL)) IF(ISEL.GT.NNSEL) ISEL = NNSEL Q(NNSEL) = UNSEL(ISEL) DO J = ISEL,NNSEL-1 UNSEL(J) = UNSEL(J+1) END DO NNSEL = NNSEL - 1 IF(NNSEL.GT.0) GO TO 3501 C WRITE(*,72) (Q(J),J=1,N) C 72 FORMAT(20I3) Z = 0 DO I = 1,N-2 R1 = Q(I) DO J = I+1,N-1 R2 = Q(J) DO K = J+1,N R3 = Q(K) Z = Z + D(R1,R2,R3) END DO END DO END DO 3502 ITRIG = 0 DO II = 1,N-1 DO JJ = II+1,N C R interrupt CALL rchkusr() C R3 = Q(JJ) R2 = Q(II) DELTA=0 DO I = 1,II-1 R1 = Q(I) DELTA = DELTA + D(R1,R3,R2) - D(R1,R2,R3) DO J = II+1,JJ-1 R4 = Q(J) DELTA = DELTA + D(R1,R3,R4) - D(R1,R2,R4) DELTA = DELTA + D(R1,R4,R2) - D(R1,R4,R3) END DO END DO DO J = II+1,JJ-1 R4 = Q(J) DELTA = DELTA + D(R3,R4,R2) - D(R2,R4,R3) DO K = JJ+1,N R5 = Q(K) DELTA = DELTA + D(R4,R2,R5) - D(R4,R3,R5) DELTA = DELTA + D(R3,R4,R5) - D(R2,R4,R5) END DO END DO DO K = JJ + 1,N R5 = Q(K) DELTA = DELTA + D(R3,R2,R5) - D(R2,R3,R5) END DO DO I = II+1,JJ-2 DO J = I+1,JJ-1 R4A = Q(I) R4B = Q(J) DELTA = DELTA + D(R4A,R4B,R2) - D(R4A,R4B,R3) DELTA = DELTA + D(R3,R4A,R4B) - D(R2,R4A,R4B) END DO END DO IF(DELTA.GT.0) THEN Z = Z + DELTA Q(II) = R3 Q(JJ) = R2 ITRIG = 1 END IF END DO END DO IF(ITRIG.EQ.1) GO TO 3502 IF(Z.GT.ZBEST) ZBEST = Z 3500 CONTINUE C WRITE(2,3505) ZBEST IF (IVERB == 1) THEN C WRITE(*,3505) ZBEST CALL dblepr('HEURISTIC OBJ VALUE', -1, DBLE(ZBEST), 1) ENDIF C 3505 FORMAT(' HEURISTIC OBJ VALUE ',I12) Z = ZBEST-1 DO I = 1,N Q(I) = 0 END DO C M=1 Q(M)=1 S(1)=1 trig=1 DO K = 2,N Q(K)=0 END DO C 1 M = M + 1 C C CHECKS=CHECKS+1 IF (IVERB == 1 .AND. M .GT. OLDM) THEN C WRITE (*,6000) M+1, CHECKS CALL intpr('reached position', -1, M+1, 1) CALL intpr('with following number checks', -1, CHECKS, 1) C 6000 FORMAT(' reached position ', I5, ' with ', I9, ' checks') OLDM=M ENDIF C C R interrupt CALL rchkusr() C C main loop C 2 Q(M)=Q(M)+1 C C MFH: Make sure to not get out of bounds with S(Q(M)) - 9/24/12 IF(Q(M).GT.N) GO TO 222 IF(S(Q(M)).EQ.1) GO TO 2 ! REDUNDANCY 222 IF(M.EQ.1.AND.Q(M).GT.N) GO TO 9 ! TERMINATE IF(M.GT.1.AND.Q(M).GT.N) GO TO 7 ! GO TO RETRACTION C only for bburcg IF(TRIG.EQ.0.AND.Q(M).EQ.2) GO TO 2 ! SYMMETRY FATHOM C S(Q(M))=1 IF(M.EQ.1) GO TO 1 IF(M.EQ.N-1) THEN CALL EVALBBURCG(ZBD,Q,N,D) IF(ZBD.GT.Z) THEN Z=ZBD IF (IVERB == 1) THEN C WRITE(*,*) 'Eval =',z CALL dblepr('Eval', -1, DBLE(Z), 1) ENDIF DO I = 1,N X(I)=Q(I) END DO END IF Q(N)=0 S(Q(M))=0 GO TO 2 ELSE DO 251 MM = M-1,1,-1 ! Insertion Test R3=Q(M) IDX1=0 IDX2=0 DO I = 1,MM-1 R1=Q(I) DO J = MM,M-1 R4=Q(J) IDX1=IDX1+D(R1,R4,R3) IDX2=IDX2+D(R1,R3,R4) C END DO C END DO C DO 250 I = 1,N IF(S(I).EQ.1) GO TO 250 R5=I C DO J = MM,M-1 R4=Q(J) IDX1=IDX1+D(R4,R3,R5) IDX2=IDX2+D(R3,R4,R5) END DO C 250 CONTINUE C DO J = MM, M-2 DO JJ = J+1, M-1 R4A=Q(J) R4B=Q(JJ) IDX1=IDX1+D(R4A,R4B,R3) IDX2=IDX2+D(R3,R4A,R4B) END DO END DO IF(IDX1.LT.IDX2) THEN S(Q(M))=0 C ism2 = ism2 + 1 GO TO 2 END IF 251 CONTINUE C go to 253 C DO 151 MM = M-2,1,-1 ! Interchange Test R3=Q(M) R2=Q(MM) IDX1=0 IDX2=0 DO J = MM+1,M-1 R4 = Q(J) IDX1=IDX1+D(R2,R4,R3) IDX2=IDX2+D(R3,R4,R2) END DO DO I = 1,MM-1 R1=Q(I) IDX1=IDX1+D(R1,R2,R3) IDX2=IDX2+D(R1,R3,R2) DO J = MM+1,M-1 R4=Q(J) IDX1=IDX1+D(R1,R2,R4) IDX2=IDX2+D(R1,R3,R4) C IDX1=IDX1+D(R1,R4,R3) IDX2=IDX2+D(R1,R4,R2) C END DO C END DO C DO 150 I = 1,N IF(S(I).EQ.1) GO TO 150 R5=I IDX1=IDX1+D(R2,R3,R5) IDX2=IDX2+D(R3,R2,R5) C DO J = MM+1,M-1 R4=Q(J) IDX1=IDX1+D(R2,R4,R5) IDX2=IDX2+D(R3,R4,R5) C IDX1=IDX1+D(R4,R3,R5) IDX2=IDX2+D(R4,R2,R5) END DO C 150 CONTINUE C DO J = MM+1, M-2 DO JJ = J+1, M-1 R4A=Q(J) R4B=Q(JJ) IDX1=IDX1+D(R4A,R4B,R3) IDX2=IDX2+D(R4A,R4B,R2) IDX1=IDX1+D(R2,R4A,R4B) IDX2=IDX2+D(R3,R4A,R4B) END DO END DO IF(IDX1.LT.IDX2) THEN C ism = ism + 1 S(Q(M))=0 GO TO 2 END IF 151 CONTINUE C CALL BOUND2BBURCG(ZBD,N,Q,M,D,S,DD) IF(ZBD.LE.Z) THEN S(Q(M))=0 C ism3 = ism3 + 1 GO TO 2 END IF IF(Q(M).EQ.1) TRIG=1 GO TO 1 END IF C 7 IF(Q(M).EQ.1) TRIG=0 C MFH: Make sure to not get out of bounds with S(Q(M)) - 6/9/15 IF(Q(M).GT.N) GO TO 777 S(Q(M))=0 777 Q(M)=0 M=M-1 IF(Q(M).EQ.1) TRIG=0 S(Q(M))=0 C C WRITE(*,*) 'X',(X(J),J=1,N) C WRITE(*,*) 'Q',(Q(J),J=1,N) C GO TO 2 9 IF (IVERB == 1) THEN C PRINT *, 'total number of checks: ', CHECKS CALL intpr('total number of checks', -1, CHECKS, 1) ENDIF C Return R RNG CALL Putrngstate() RETURN END C SUBROUTINE BOUND2BBURCG(ZBD,N,Q,M,D,S,DD) IMPLICIT INTEGER(A-Z) INTEGER Q(N),D(N,N,N),S(N),DD(N,N,N) Z1=0 DO I = 1,M-2 R1=Q(I) DO J = I+1,M-1 R2=Q(J) DO K = J+1,M R3=Q(K) Z1=Z1+D(R1,R2,R3) END DO END DO END DO C Z2=0 DO I = 1,M-1 R1=Q(I) DO J = I+1,M R2=Q(J) DO 60 K = 1,N IF(S(K).EQ.1) GO TO 60 R3=K Z2=Z2+D(R1,R2,R3) 60 CONTINUE END DO END DO C Z3=0 DO 90 I = 1,N-1 IF(S(I).EQ.1) GO TO 90 R2=I DO 91 J = I+1,N IF(S(J).EQ.1) GO TO 91 R3=J ZA=0 ZB=0 DO 92 K = 1,M R1=Q(K) ZA=ZA+D(R1,R2,R3) ZB=ZB+D(R1,R3,R2) 92 CONTINUE ZCT=ZA IF(ZB.GT.ZCT) ZCT=ZB Z3=Z3+ZCT 91 CONTINUE 90 CONTINUE C N4=0 DO 93 I = 1,N-2 IF(S(I).EQ.1) GO TO 93 R1=I DO 94 J = I+1,N-1 IF(S(J).EQ.1) GO TO 94 DO 95 K = J+1,N IF(S(K).EQ.1) GO TO 95 C ACT=D(I,J,K) C IF(D(I,K,J).GT.ACT) ACT=D(I,K,J) C IF(D(J,I,K).GT.ACT) ACT=D(J,I,K) C N4=N4+ACT N4 = N4 + DD(I,J,K) 95 CONTINUE 94 CONTINUE 93 CONTINUE C N1=N*(N-1)*(N-2)/3 ! This bound is OK! The N1 is total C N2=M*(M-1)*(M-2)/3 ! and N2 and N3 are truly computed terms. C N3=(N-M)*(M*(M-1)) ! So N1-N2-N3 assumes +1 for rest, which ZBD=Z1+Z2+Z3+n4 ! (N-M)*(N-M-1)*(N-M-2)/3 +n4 C WRITE(*,98) N,M,N1,N2,N3,Z1,Z2,N1-N2-N3,ZBD C 98 FORMAT(9I7) RETURN END C SUBROUTINE EVALBBURCG(ZBD,Q,N,D) IMPLICIT INTEGER(A-Z) INTEGER Q(N),D(N,N,N) ZBD=0 DO 85 I = 1,N DO J = 1,N-1 IF(Q(J).EQ.I) GO TO 85 END DO Q(N)=I 85 CONTINUE DO I = 1,N-2 R1=Q(I) DO J = I+1,N-1 R2=Q(J) DO K = J+1,N R3=Q(K) ZBD=ZBD+D(R1,R2,R3) END DO END DO END DO RETURN END seriation/src/arsa.f0000644000176200001440000001740714452345572014157 0ustar liggesusersC ANTI-ROBINSON SERIATION C simulated annealing algorithm - provides an initial permutation C by Brusco, M., Koehn, H.F., and Stahl, S. C R Interface by Michael Hahsler C PROGRAM SANNEAL SUBROUTINE arsa(N, A, COOL, TMIN, NREPS, IPERM, D, U, 1 S, T, SB, ZMAX, RULE, TRYMULT, IVERB) IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION A(N,N) DIMENSION IPERM(N) DOUBLE PRECISION D(N,N) REAL S1, RCRIT INTEGER U(N), S(N), UNSEL, T(NREPS,N), SB(N), Q, NREPS EPS = 1.0D-08 C Defaults C RULE = .5 C COOL = .95 C TMIN = .0001d0 C Initialize R RNG CALL getrngstate() DO I = 1,N-1 DO J = I+1,N D(I,J) = DBLE(J-I) D(J,I) = D(I,J) END DO END DO DO 999 III = 1,NREPS DO I = 1,N U(I) = I T(III,I) = 0 END DO UNSEL = N DO 1 I = 1,N C S1 = rand() CALL unifrand(S1) ISET = INT(S1 * FLOAT(UNSEL) + 1.) IF(ISET.GT.UNSEL) ISET = UNSEL T(III,I) = U(ISET) C DO J = ISET,UNSEL C out of bounds error reported by Rohan Shah (9/13/12) DO J = ISET,UNSEL-1 U(J) = U(J+1) END DO UNSEL = UNSEL - 1 1 CONTINUE 999 CONTINUE C ZMIN = 9.9D+20 ZAVG = 0. ZMAX = 0. DO 1000 III = 1,NREPS DO I = 1,N S(I) = T(III,I) END DO Z = 0.0D0 DO I = 1,N-1 K = S(I) DO J = I+1,N L = S(J) Z = Z + D(I,J) * A(K,L) END DO END DO ZBEST = Z TMAX = 0.0D0 C DO LLL = 1,5000 C Find initial TMAX using N*10 tries DO LLL = 1,N*10 C S1 = rand() CALL unifrand(S1) I1 = INT(S1 * FLOAT(N) + 1.) IF(I1.GT.N) I1 = N C 199 S1 = rand() 199 CALL unifrand(S1) J1 = INT(S1 * FLOAT(N) + 1.) IF(J1.GT.N) J1 = N IF(I1.EQ.J1) GO TO 199 IF(I1.GT.J1) THEN JDUM = J1 J1 = I1 I1 = JDUM END IF K = S(I1) M = S(J1) DELTA = 0.0D0 DO 1250 L1 = 1,N IF(I1.EQ.L1.OR.J1.EQ.L1) GO TO 1250 L=S(L1) DELTA=DELTA+(D(L1,I1)-D(L1,J1))*(A(L,M)-A(L,K)) 1250 CONTINUE IF(DELTA.LT.0) THEN IF(ABS(DELTA).GT.TMAX) TMAX = ABS(DELTA) END IF END DO C TMAX = Z ILOOP = INT(TRYMULT*N) NLOOP = INT((LOG(TMIN)-LOG(TMAX))/LOG(COOL)) IF (IVERB == 1) THEN CALL realpr('Found tmax', -1, TMAX, 1) CALL intpr('Steps needed', -1, NLOOP, 1) ENDIF TEMP = TMAX DO I = 1,N SB(I) = S(I) END DO C DO 2000 IJK = 1,NLOOP IF (IVERB == 1) THEN CALL intpr('Step', -1, IJK, 1) CALL dblepr('TEMP', -1, DBLE(TEMP), 1) ENDIF C R interrupt CALL rchkusr() C DO 2001 KKK = 1,ILOOP C S1 = rand() CALL unifrand(S1) IF(S1.LE.RULE) THEN ! INTERCHANGE / INSERTION / OR BOTH C S1 = rand() CALL unifrand(S1) I1 = INT(S1 * FLOAT(N) + 1.) IF(I1.GT.N) I1 = N C 99 S1 = rand() 99 CALL unifrand(S1) J1 = INT(S1 * FLOAT(N) + 1.) IF(J1.GT.N) J1 = N IF(I1.EQ.J1) GO TO 99 IF(I1.GT.J1) THEN JDUM = J1 J1 = I1 I1 = JDUM END IF K = S(I1) M = S(J1) DELTA = 0.0D0 DO 250 L1 = 1,N IF(I1.EQ.L1.OR.J1.EQ.L1) GO TO 250 L=S(L1) DELTA=DELTA+(D(L1,I1)-D(L1,J1))*(A(L,M)-A(L,K)) 250 CONTINUE IF(DELTA.GT.-EPS) THEN Z = Z + DELTA S(I1) = M S(J1) = K IF(Z.GT.ZBEST) THEN ZBEST = Z DO I = 1,N SB(I) = S(I) END DO END IF ELSE C S1 = rand() CALL unifrand(S1) RCRIT = REAL(EXP(DELTA/TEMP)) IF(S1.LE.RCRIT) THEN Z = Z + DELTA S(I1) = M S(J1) = K END IF END IF ELSE ! INSERTION C S1 = rand() CALL unifrand(S1) I1 = INT(S1 * FLOAT(N) + 1.) ! OBJECT POSITION IS I1 IF(I1.GT.N) I1 = N C 599 S1 = rand() 599 CALL unifrand(S1) J1 = INT(S1 * FLOAT(N) + 1.) IF(J1.GT.N) J1 = N IF(I1.EQ.J1) GO TO 599 K = S(I1) DELTA = 0.0D0 IF(J1.GT.I1) THEN SPAN = DBLE(J1-I1) DO L = I1+1,J1 Q = S(L) DO I = J1+1,N M = S(I) DELTA = DELTA + A(M,Q) END DO DO I = 1,I1-1 M = S(I) DELTA = DELTA - A(M,Q) END DO END DO DO I = 1,I1-1 M = S(I) DELTA = DELTA + SPAN*A(M,K) END DO DO I = J1+1,N M = S(I) DELTA = DELTA - SPAN*A(K,M) END DO SPAN2 = SPAN+1 DO I = I1+1,J1 SPAN2 = SPAN2-2 M = S(I) DELTA = DELTA + SPAN2*A(K,M) END DO ELSE SPAN = DBLE(I1-J1) DO L = J1,I1-1 Q = S(L) DO I = I1+1,N M = S(I) DELTA = DELTA - A(M,Q) END DO DO I = 1,J1-1 M = S(I) DELTA = DELTA + A(M,Q) END DO END DO DO I = 1,J1-1 M = S(I) DELTA = DELTA - SPAN*A(M,K) END DO DO I = I1+1,N M = S(I) DELTA = DELTA + SPAN*A(K,M) END DO SPAN2 = SPAN+1 DO I = J1,I1-1 SPAN2 = SPAN2-2 M = S(I) DELTA = DELTA - SPAN2*A(K,M) END DO END IF IF(DELTA.GT.-EPS) THEN Z = Z + DELTA IF(J1.GT.I1) THEN DO L = I1,J1-1 S(L)=S(L+1) END DO S(J1) = K ELSE DO L = I1,J1+1,-1 S(L)=S(L-1) END DO S(J1) = K END IF IF(Z.GT.ZBEST) THEN ZBEST = Z DO I = 1,N SB(I) = S(I) END DO END IF ELSE C S1 = rand() CALL unifrand(S1) RCRIT = REAL(EXP(DELTA/TEMP)) IF(S1.LE.RCRIT) THEN Z = Z + DELTA IF(J1.GT.I1) THEN DO L = I1,J1-1 S(L)=S(L+1) END DO S(J1) = K ELSE DO L = I1,J1+1,-1 S(L)=S(L-1) END DO S(J1) = K END IF END IF END IF C END IF 2001 CONTINUE TEMP = TEMP*COOL 2000 CONTINUE IF(ZBEST.LT.ZMIN) ZMIN = ZBEST IF(ZBEST.GT.ZMAX) THEN ZMAX = ZBEST DO I = 1,N IPERM(I) = SB(I) END DO END IF IF (IVERB == 1) THEN CALL intpr('Rep', -1, III, 1) CALL dblepr('ZMAX', -1, DBLE(ZMAX), 1) END IF 1000 CONTINUE C Return R RNG CALL Putrngstate() RETURN END seriation/vignettes/0000755000176200001440000000000014610040326014253 5ustar liggesusersseriation/vignettes/classes.pdf0000644000176200001440000007141714204252545016424 0ustar liggesusers%PDF-1.4 %äüöß 2 0 obj <> stream xUKk1 ϯ90Sc aw)f[)4J留nl燤ﳬ@[[1נҁןUicJkxRiN*tk7]SpUgn)ĺ$DfW%D $[:ծ##& Xpf$> stream x| `U{UuJӝT@$rI7I!Ish:Ґt"(댣#xp 3*ˆΌ̸nd\]'Bޫt'DoTzw}@#n/I!+ ^Ql\u<@"9[w.o=֎8|h1^߁?ߏ]kɟ%Ģ{Sgs \/~|W.oǎE4!SM@8r9y! x0 ^{ Ix(^'.()lIK'_v:ɿc{*@xc/{nNҋm8&fg8~xIt,i#`DH&G&z4Sϥ'Da"Y vSMv-7mx(./^'&^G0h=er5t-&k5y?WW[-ڄ3A/Oi9]@ߪ*zJ $!w4|{@?"T[E[E xσ1[x}B6%T2d$P$|AW-@4bcEtBLl]R|`hqC>‹.Y>܅+5}ݍr3}LlMhsq9°! &OO Ei!FJ1 f*:+ᇨ :P"=]8+ѐGV#A]VDqa"u7E&H (}2 PbUۄ:6e zU 6Ҵ͸\uD1WZM J%j1M ]tF'hΖdo؍>ƸnJO]6ݡjxҭf1Ub3\)xa0'hcA${^L̇zV[ -%v CU /> F`"KN|(Fl6c`J_3$ K1짇ČkKYVʗ rHKn)#h(^d}ؒ6PG{gG̟I˞X&M['ꏅE)]d*))INJNNI6&JSZ˒䲔2hebI)fɳg4w'N-NޝXb2L$lL`6I"j)Ě*fefE#-tlq崌V?2K}u{kMVB |bߒi}1;TU%'{tbj7nĊrcboߒrǂJ<4T IiCak)$fI`L<;ڻ`;lV1X2ekY[{5ݱcEڅ<+??~Ll5O$ǦD(v*[c>2:O 3d-/{=9h&3yç'2DbyceQG*v6#%1JӹGh> 1Yg~upx wm'x=&b_l^n3;QⳍLKbHr@2Rƴ:po%;cR FVlr#rڗr6oę@]'>u53ּ8]:|x|08bxk#ܽغ֠Џ b+AsSДw3f6i-sT8\[0Tl]cl-䘔UEh`dՖWvue«t%xq-=ť[FnCۢ#L\Ս҃$tنTXo;919IHB'0Wfa4=e){U6z42-mjN4 MД*@PdKFdlVY-c-XzzǥWR҃ 'Z0!.F=FK]d 9 kM-WG-ƄBa1ɘ<KY>ETxף0ϏLLag/9UZ8meN"eQ_ޠPyr[[(fVWT Z 7,;΂ o+0/, $jqz" \qVS6sMҢ7ÿK#~V͜FrM^]#6QˈrL0i CD"1'M]–ԔԚLZ$r3na~/28K#dM }i%MO陓Yӑ'&O˩M8QOfW X}ݴ:=?OZe/xL/x]ҟS4%TنRT~7`>xf&US"&ge?UJSW͙31^=ËGn/ɕ $.9̶ܟu(gmZI;קCBi 1ltQc>wQٶ Y.eA b4k{(M9н}PUu_m{_^mW/JcSCfZ WYU4si y$ yX̲ *I2HXI"I0ڹ fs+}ڮg/El<]X))sx % cuNGp\@/x2NbE 2Aؚx#EaV½=fx>`I/LB'+,lEjz _|*ܧz̴xH^ogc0H2&c*[urVE|;չ7rAK -n\ë?9W_WhGyxb݂:f5 1CCyW+޻~n8YstO$UY4X/)DjJIO!<}2֫0Z(BfFrRrJ"H?OKL!` I4){+lL̷GVgiB n1t;EhPi=Bo}]f`m @ թxh꼇^:3R?I_}KKXK؉S8jK͋\_dEdn%qyDN$Wj' gF+8o)ظXNgD)yz-0^A=m%^1itYT&ؘ㓉2̨̫姘Wm=) ~7=G!"SG$T^ee@wm{ >ĔAz6oggtr )˃a "^ t)w.J[,,Ǹz.EuyisƦUqe <.WhhLE._V:!/ZrQu+j2D q*/Wh5\h b>QhgF:Q@W ({aDCR4yW8p\O]^a:HE@i Gz\7 x^NC|m/Afvwv{$=HG;ttFCHvq>SǪty2wp5,퀳}( L8$d@Gd :Ψ !?2򅞀Xpw;z~Nt6;IDr2/@".@4CXeV <@SNͫb`_@;JdyBFePG\1Zpcꌠa< PWtd XEC]n$f+sb$edsuM@_#F w.W|qn.3uB^vF /7BREwt@.ba[!CHbT e_`k#1+ruzـ;Rf 9fWDp?u1(~.pLT ix:1ycTs1#N=0V.RbT ~= lgBt(3JK |{CkQ8j"{ YuΙs h78*3{Bev]CUq,hjvȍJݜ:5TϭkU㺆FR_7ΉD|Nˆq4WW:B<ـ4QfŮ4ٛusJҨA u 3c@BՍM jg:ȉVlq̱7϶*HUnV2i(ylqL{}2lv簹 چ9yF܆A@UlJunUϱ2uL4M2[Php4JK5ǺfGDz.nucC㲹؁,j.Wet~Q׵8YdFs#8{\ēAو8q` ;sѻ׺m=Ө;k$.\x%,h-aت^>лq'Rg3`@Hd H-+yJՉp"> sPrt3 |'`2Q\@߆C65Pb0.򆃸Ky;˸$>?j]>wdRT(9qO "cEW2ιt:AV)gSɱ:H9:H>ғS G! X"KDk%Q+ɚZIj%|Kc8_咬K9Kqw.d@9I>%LٗLI9IdRN$;jdbgUu$4?HVGʹTGr|uUu$Y)R1g(|G|G9G Ht r>N{rU[+a,,ؠ4RM$HŤDBF7JRXl L9"V#~_-;K!͋O/YwΔπ~N y-5~pᚯDZ[Kp<ҍ38ũy HA*~qN< ©QbT9y\0 pI*Q뢫Ɯj;_!Đ^H9^}2_ ^6Q)C^\3#ZN6ƐryQVR-,9|ǂ\6C W0`T Be1aFk(5빰ɾ.(~m>y+{uqb_-U0͚8.N->.Sz-\խ5ki4 pkR>ӽihH:b?<(6[]e/\⼤[g5.]?G=S(>#iT1,0#迚31LXOG94AZFC> nS0>NDGk!4+5i98vfk9.qzX,DᔵxhtTZZGӤ {tF=3v8~g<ɐX3ܜ6'jvh-j!7tI'tҹbg sQ 3Ghb9 ~uvqeNc]gb߉5*2L{Ɲae4ߣI0<;>3:ܯKCc}U͡.=Fy ':Eu b6:s PYu{wuSds:!g]jGu#nԐkF2Y7;M8i:k6pfฦKYBMțͨEɩϴr;2}jzu6I֨[cTt,599pRNqrؑ~nwj9&јs9|CYqqVx11k8';GeHM3wj~T=݂8:p~]u\jkOǡ[ud :tsj4B]Wa~nݨZƪ-wkDUZ J W&=|4<~k?^Օ.^-0n!<%eƥ#ze leHDur?Կ|aVOtC$]Ä!u zId`qL3:S*zݟ:Sy<ys${[yJ}O}}ktI&O>vNӠ!>e\|LIt6O9vv'>r܉ M$6;i9Vv檜˹l^55}47?VR%Ă h!, H,}E|kUxك|4 9x%x{r}g{g bBvRYi H#"Mɘ3$>DLeR}ln>4Lla${:5p$~, ;X'.Uc_Zc*|i>EE-O|g*U* |8ǽ 2YJrW>—T8‡* gI{a|]>C }3eo3-3z3Y:x^GHfHoÌi=>^yyxeK%ˋeR F_{`fi /Tx^~5Iz~5W$xҳTi ٝ"I)2{J]*< O?S*lφ_,x<>؊|lYH)B*<&~.F`Ra 6>XKZ|QG*~[HoܷR\sGfc ?+UpU܃KQ)p7v= ]]Yp(TvnS'*ܪU-%ҏTAUJ*;nRae( *PzrzmzTX #RwDr!p U X]}KUXOwQ UhG*xdDw,SMWkZ"f2\"+U\ .Ƿsa ` vb sUpCK4_#5e8pY45HM}`ss~vT gY0$Ͳ@ fA 6fdjMRM*T`Dvi/۴Tɦ´KMҴTSY0=0Ip a|pi| TːCs8(ˀq+ű) k+SM*T MPe0:I: .¨LmFC%pA1pPl"b0 m2Cވ)FK#r`.wF3[rilB[Vdb_f dx i*Xݢ&ω&3VF1AJ%$jYR $UHP ɒAI&}pb2Jt|;]  endstream endobj 6 0 obj 8718 endobj 7 0 obj <> endobj 8 0 obj <> stream x]n0E|"& BJIX~R1q}=ya5ڧnx6hI`j)-=o96I[fck,-f:I8mlQw!n~3TS09O}GHjݪP~Y_be1̶zsbeT & \ٻ*B+M87ϐw 9Q{ "##qYO{s,~y`w~@_#1p[c37[tU, fݗ endstream endobj 9 0 obj <> endobj 10 0 obj <> stream x| t[յ+YG,Wƙ"Ŗ[H5r!L MH@JCJ˔-t-tZC?$7s;N0{ιyNVQ?2#7HWrc iן⿇w( o!wm#? u=CpMy+B ? _>z)z!_l- 0ÞxۣxnP7/Ec~ĵ~ 09Q!ۈ+~ ps7ra58"&Пa}SZ vrq5&v u].+׸]e/_7\zy{Wp 77f|)>[BP\@vX|Eu93 ~Gh*O8$˕rt-~M^n@p/j vw5n#f0ο_Co@_ow\X{ZKX>2i{ wpE_j䢝Ux!nF?GsH|QDf& 6kF=Ѓn:YF0!dW:^!:>e*^Գ7{tɞBr8c/+TU{αլbu7Z ,úyB< ;28 ;H%^ K<\e5[:ǥ,?( 1j9h6FP^D(+/k$rܕ_Ѡ' V0Wr}Cvkjݾ7Ͻ}νjųv+7G?6n? dҚ 9ʂa2..~K~Ade,_p Wa[ ʹ2."Xm.+/?oV-W͟Wi/6fpqͧ_?ܲvb]s͕r+[8bkKG*+* /U'AG3AKKըAp9Ո+_TcѠ17tlqsGU0~$ACZB*,\P9^ȷhAfZ1p9~u޺p|&yB~oA8^~M&4$o?zze$4xl· }۱QÍ:]V٨aᛍ;tz Qg5;*s c2S̪-`M+m$3ǭqTHH$#9aG\?o6aؚg^ ,(fV]3K?pCqC^spx $zr\)X##N@`:*W||#/@m aA*G;E|I|R bmf>K>iD%fтKfK0 B{o ϴK{72[k> Ԑ3Tz"`_U2^pCk%==y375d'_]P`-R|@GbtұA*/98Z$@1/l1fgBt6\ˬbeEEYp+++EA*u,xG&[YK 5:M>/!UHSE*+c?<@2.y)zKi/˘* 423&lLIcҚL:1MSh1L9p) -\SEQ{=)Fudт#Õ ߙ9<~a0 ?vgY%'Kr^ÇN/i,t3xS}]zj͐WB?*Futc49}јc$z@'YZ8vD8xPsgsrP)۠2rU%44'C>Ӌ^H/&zɡ3KۅJ>j7e^&1j9Ҫϰjn_])b#<+.d~ 9:yl|S׺OxpQ˓}nOTtG+ w]ROtA-A,pCbq"qۤ‚|1۠ςCFl.1R+*t^KJe:0 84d;j37; Td LօyyswsoK+4{/w]O"yTDuJzT 3"e*S 'pf7M9 ٢oiPh{4抻lw΂e(.2+ g[&8 C,&smnf ⦚c#OGAÎ25g6eAql\).L틖B %M-10mg \5_?{|KÑaGޱ ×ؠeK1ѥdtRJ,,dvl*rU+hJGOM99cc7]73d:#Juhn.tV*` t-m ~&/G^Is ;hȄP".iZ)SyO]0]}uQzF 0~YGuA8 A!!۰2}UF4/UulBzK32X@tTg)T*oU<*_1US"5Ȟ:BbuGƂ$#ulB'y04EcT-͕6Jx"R[[#9GF^ zql!l]@=cHxPZ:fg٨qK z%_$ 0}p|qd'uuel֗c`$,\ҠP9d@$ <&@D"X[њxd4"AM؟ha`c*sJMRu#kFjKP4K}R  IΘLe%IsTg&BAJ2 s9|gmyi `xDGA#w4'< O 8F/Hf3Nbh,_ &2iQNC0 (J@;x*] Ԅ9H|ȞANiFbRv ?4eFDQ#~ XF_DGR|t`M*_ 2FF¾ #Hy"c~&E# 0C\YV=@y&Ň<##dj ؀(L3IH?RbcOC- yFz0I'|xb0ccPUD=$q#O|*%0=I>؀F)愊ӿ `tvI|cGbdKšN> 662L/~$ul@u2 oH@Hh303Q< i$PK{O TӬƜ"ᙬiPQ#y= VQwg8 GuTHA#[˝.O^jl>6n z]RwZ)u5%׊^W_:{:\ԱUZ RG[gVU"t6-sq[G{'0+9giiWỲ:]  jYֺmMnXwmKDH p 8$2oCZsjEZv5;m]b\RxQ:mvl$P0E:r:;R_@m&7݃&:M]}%I%.FpŸ& ĥxݽ+\vG- R{v0X R6kz@ݪ.g l GԷVR#KJ3UpkWYcC8 ةdMczYHI1?d8M%d>gG`(yR3`"3)6'IXL$(Ƃc8SL)-N 1< Tp?`c,cPTљdr_$AayNg[^:(ut.uIA9A:HM^)<3)P 9ZIJJQ+[D=Z\Zk%k%2.8ZVξV"RfN*<$q%KyKdBL$λd"d"j${DLҹLdڒI,%q;u^Mv.9ꈤ%?$#|#YITi#|#ꬓ%U>g(|ș ,  ɵ/hIx+H jع]\ BP֪i4}6Ԅ"(6 A4HBȋfýw.BB&!?j | hMኳ~3W@ E ƀ0 4{>f þeh alI$0\3x'PgS1,q(>XVw@K ~2d5L“2'L4 DŽjehק| EMi Þ lI'|7gn~f{?AZ؏bj'f ³(;|j vPXǦhei䟧w:[z`S#%K*.|OoAxB(VZ,x0|!-A{WdTªk)S0y `M>Tp(&*b?yC{VxW|X=[ؘ^_^Q#, !%$шI)h&':+Q5>e k4*4(hg XI L2&y(ӡ=:tbTlM22HvO#=%g- ìă;ju,uRs єG'_iKK#tV`Y;JϠcWJTeDQ2[B^F86tyce 2sQZf0'hOMJZc9 sd0 ͓}Mцrx`;$!vO珳EDLԙRlT:yS=ii,pJu˰y%OP;,gIIcR{318\U(%syIS2%$i0=LtU{}dsNY+iɕx#2yϤHRZϤiC[J;O'YᶋY\ GMpr3-PJnHif)vp֭ZXjT]*|P/KQcwWbalIIie(߄ic)(,fpTT)ͰJ弙Qr2M+I[us1Mu0>У R+?1YT]+8W|#CMLFj٫K)'d)3R(pצ ߥZ7ɏQvO,] lݗ*KSKUNq6Y8JMPp%iO`3þ6rJre9Tޞ|rgVj4gJ@­ 64.-)gV]'v ;vɪ7]}([y'ʬz}>Wjx*:0Lֳ3=N"(e;)Zɳ(K+=Zh'90{z6N oT뛦 '?@IY2cRAaZO֨xc(^ ՀW Mz(F4@u0 GGi=/t{_~Zy}~ 2m?HAA+yoO^G:uXȗWN+W+; 9Jd 4ok_+3 A[ WJNwsu]t+ehe"Nf. wȔ.S]2e. ]&s2e*ƭm'H~xL|؇8P P~첈]]| w^OT;'w;U-=o`N 2ko=U*5p{MƷ-+L-2ś'MRF|7K7o7m̀2[reYƛdo( p O8[pLfᨌ#28D䈌ŵ26a'*Ãp10e>/dX#zޭ*q` p_W#|-l k$ڀWªv| ܮJe^a˫2/[}22{v*e2qmx/q-=b]{psS\,".qA>η|3qĹۈ26&- flE cd's a@F,8J1\E#ss8ߍwpIeП endstream endobj 11 0 obj 8294 endobj 12 0 obj <> endobj 13 0 obj <> stream x]n E|t;dYJD0vj0Y0i+u:3s/KT7F+Y7+0*͒K%ܽ :"ma.K7G9W+*=GhcVU\yK7A\Fr[OCU,a1X//fɎ, >;륉><9~ _sO{#@H|@~"ggy 3IOT\ܬ1 `2Jߙ٠+oҌ, endstream endobj 14 0 obj <> endobj 15 0 obj <> stream x{ |Tw;ܼfaHr2 I $ nf2s'Hfƙ 1Ej b_*RV)* Znn[Z+Բ]v#\|߽ "cafceN6 +X3sDy.۽>"8'{w|>BRg.ϳ—؃paO?⼬o rF !8%nW,/ƹ43 g_v.+Gn'Ϝ'dy747"oJǡu C/{q(9>ۋ3/.߁+u2+/r'9&"6r[F*!o:rsCc!-Lo~?Ia$͇R؋c]6 )"ܛ$Loa.L&}F;ydn΁+/ 'In*rw"y<n)Žr $_n\q0O9(ٸ#]s4لd~TRTr/rU,RCtazFQv@nn-ߝ҃L%BtKgHoDq[`;rJw ɔe| G )QjB0 9HفN-yw$4*C]\BFy6E/Y2Е=,&9ISɘ" 2;oYp//}bo1/M:p֤au7Zm83\u[ۣD}@rI-(A2{=Rut3t<9k9bSy˓a?2?Uo =iܠ vn qy]/<7}z_EY#=\Ff-3a,=+ulF}Y$-3 QΠkO9NS{psB@>;*剘:"4yk_{~}{^!Ͽ{cc{?:ǥU.ϓ G߆ц]t]fZWQ!U"v6iE|msm1fѨbZQ~ q2S %J訧L ROU3^^ߙ/La߫K [c%J^jiEEi$"qeJ2톜ܚUVUIUe[ŭi[ӷfdtE}CdBa&\0/HZRU6W=PtՌ5d\^5j+rT Q5\5GM_7 ۷|c?b%-yKt:-}c歾uygyV7t!4]$Z=S0dS5lP<13sgu,$,>>NãwPG8ؔ;mGt6([Ƕmv)?qns]mM֒OK!4ؖ9z4E9ڬ) PgηstHSՑ *9tXVd7|blȖYp(tع|3^ 0zw/f%|{̭g\Aڮ3=U7u3Ej-iY|Fhy4 I1ZG;K|;k)p='ߞ={_YG&՗22[1C ;1?ݮ;N5{"E+ MǓՏ3dy/!reG5f6+y< GNhXZ2EpZЫB#skʆoBrI> ZHp'sMoV~ΐg uYYcY)#ރ3PT-).ia Y--[/Sj 5.$t@~*&5 bXH4ZP/),RMg|v=S(/sUgåsc~nz3w3'r9\zfse!J%eFӏ@N׸zi-bu;h&ʁ~o犿Z>)2yWʔ!x2$>Lz<ݫ?D%\r5g)Yp%w=BB r1?N.0>ZԽN[g ),RzX(w|>ic=ן<jcz~ _iX_ُr'LrS.ml$i9?& )r|*2T6fm# m ^y۴@f6ܼ֓66m8=3ƙoQ66ihc1,z1z"RJ+ K H8]fwWK~A’CˡZ|zZ?6\}9$uIJÒ+$K>%O`Ga\pC .a0\)¾_q jD55\_?X ܲ7ꕫrQ1ʰ,K=r`Z `_X 쑼d 5V4U %8u%,ιK mKie_XtI#B뤀w2QC0S/,!i\~݌Xx 5z6KKA4DPc>TKr#"BF䨞@)@eWTRR<+}.'zqE(?^_?bd72/b`(t LJz#2AL:`F3=!_/0Af|!J!cd*$gNa4k!),ڇjO"MCA舨CǺ5w0G2; HY B٨@rEщ\=2@"@ !RI>W#kZC60J\Ir!i [ e UL%1ZQGsGpH]\U PWwDJ#}~FxzˍHDdJ\S#DcCÒ/E*NHIKaHjhxsr &s+ BŰ섋I$!?~Nb{t1,a(uٝzu%0xjy#Y=5/;,Ae  ~=W#\C(ΆՈC3 آzB=[GF-Rk\SL-30}'@@r}h0ɇ.&dWmQ.f̹xYrrj{eFBlz*Y'7Žxc{&W/׬nZKfWYS)kD1.Cմ0.&Q?TG1Phw՗e$xI =aaƗϸ4Dn%v_q 4P#迪SqЕ RpQn^%ƲG..U#>4Ҏ3JgN H۳㚄uwV W]lh\c`TW -9-GvEm u!g8pm=ш++pN-V*vT+B=[QdmtT^62eoE6ͧLwRP;bǥP-`վt~f(?NF9VVX1(+uW,FYiyX<#Y~qܡN`Vî6Txe{͞s"|s'Vj44'J@- v`\|U}ZRNb6vXUoPsLXzX}րXU`u` V z'aZOVkxC$\ ՀWdQldrW7sӵH)|q}]kݗ4Ĥ~S$^V?(w'uD!/:UEJ}%J̾t~r}%qOC_I+|<}%|ؾR:]˾R<ޒJ}/]RJ]Irwi]/])A.|j2.88L2I[I]L+2ƭm+|#qJR#ޑċ=w$~ѥ~hfraGObZv|ī\ve1sõD.o!NYUU :0Z+n'&_m=K?;wFꂷS#=o?¯Fe6s ^Ex}#<_xU)pr^9Q(Bu^b^?xQ)?T Sy*GL0\S`Q=Fx9xv3oʅk,ᰅr8GSULxzþlx ~jT *lأe c؍ G z4]إN8KL6,^!,ςEPBn^+< 0^0Bu7 u ܘ5iBmԤATsR\o(f{lrʆʊr p}yp}A dA1Y &E(@AB R k8 LGMMW`6U GlV<@F4!CtNi FHU`RrA7y> endobj 18 0 obj <> stream x]n E|tW#YRۑCu)R& }&m.@g{pInɛd(tsxWmXsWq, n=`{-|uRS,yu 6WPw7k`yʒ+=¾Z*_',xF N+"MK^%-YA~ Y*8GF>lw[=qH5tg|#F~"o\y&!7M|}b|f7BLcb>6wvČ+ endstream endobj 19 0 obj <> endobj 20 0 obj <> endobj 21 0 obj <> endobj 1 0 obj <>/Contents 2 0 R>> endobj 4 0 obj <> endobj 22 0 obj <> endobj 23 0 obj < /Producer /CreationDate(D:20080118113641-06'00')>> endobj xref 0 24 0000000000 65535 f 0000028266 00000 n 0000000019 00000 n 0000000679 00000 n 0000028409 00000 n 0000000699 00000 n 0000009502 00000 n 0000009523 00000 n 0000009720 00000 n 0000010099 00000 n 0000010336 00000 n 0000018717 00000 n 0000018739 00000 n 0000018948 00000 n 0000019305 00000 n 0000019532 00000 n 0000027373 00000 n 0000027395 00000 n 0000027589 00000 n 0000027945 00000 n 0000028159 00000 n 0000028211 00000 n 0000028508 00000 n 0000028592 00000 n trailer < ] /DocChecksum /BF659B2F14228BD45261F1C57B60F30E >> startxref 28771 %%EOF seriation/vignettes/classes.odg0000644000176200001440000002551712606356654016436 0ustar liggesusersPK28.++mimetypeapplication/vnd.oasis.opendocument.graphicsPK28Configurations2/statusbar/PK28'Configurations2/accelerator/current.xmlPKPK28Configurations2/floater/PK28Configurations2/popupmenu/PK28Configurations2/progressbar/PK28Configurations2/menubar/PK28Configurations2/toolbar/PK28Configurations2/images/Bitmaps/PK28 content.xml[[o6~>dm$>, SKHV}_! eY8 Ś8f83"7,1+ ͯtۜ#|uc\& 2&yeD4y+}%E%)9p%-ph-UKRjNVªvwTe.EwGªvv2PUNUޕP@=+PEإ$J_WUvkn]e/ Kp[VذTHőS+-۴F6jUM7fAx`.iRuzu]5bLCō#[).obԱlb4O)mM r s̳"=)eLNG(Ziv 4-0=vq ǒVGOg& ;dʌ#Ar29t4ݫ M!/6ڑ!VryAhqg>^$sQ֭q*$jb<C*q\cbynb @` X&$KX(lJ!} 5e((5PJVo"PubR=cXcZKPZ ,,S8LYdܷ3$`0uOFd^3NrA)׿ )HqR:ba$lI̻$K2#y0Vq _ s1ClqP2V$li-k)m|\V04w$>ܗAސI偘8(hmSp%VNQ-m[쎦f>(X_7zK/4la@x9O:d6Ż=A /3AyBPTCq9qP^K~7= s2NAI/Am}o&Tˀ2PL 𔔵zVں*{-&MqI& uy+Yߟgn O Pn&)1y ڞ^SLsn2C) @<'aޟ<St:[`5o!b٦..]"_ !%Br%>yyz~1wD}i{v1/+Q+aF8kM}yAlL+l~oͮ*GLּmҪ;z'њ8lJh)cYވqIV+$b,u\mg6}ogo N[n*y4P{3]OdNkܠߋp}EO DY>ÛuٯAF~v)o[|͏cci+i3ͱY}m0QU{">qZ;~#r'ȭ9$ 'N^aak9~z~mf}7XX7ۜ~ 4(W%yUr2qUVPTL h0shLPFx̝з@= y._ݳ~=ɝˤ[b-::kϑɯ@#ɝ7D]CwBTݳ!bAwA)?7^/&(SQ]zK{Mh6|\-tH#%-# =Q1f? HB0k[E7鐯nDW[^$]i4#sZ90}''uR=2طùwC== ςt^3mInz 3'&0G;ɗئzz陋ɷWg3Wk+L?z+ங?g:Ja_N0<,L+qq-Loaj`l)DUxi@X_Q$.;Y:H(Hc o+F@^*JzH낔09P0 Pxf3ؒ*57CW-&Eƽ:Ca auX%e~tCwK!,EQo{ʊfZ@ y X鉥,h}{OKMnNFoPK0J:PK28 styles.xml\_o6ߧ04to$ic/Nѭ HwZl6(PTKqodGR([rƉ@-PԼ;Q c/,oZ#, ja}}e隅!<`~XةR8NZ2JI:Qӹ,qa47j*=\)?RfgVʦuѦLMu5~H2gQ⁒naH掳lƛ1+Ǜf^qR{Na'uM,Zb$ު&ʼ Ӧ_uj_#9ϔr=U.rr>P*xu.[$6c@ovulhoo8AuQDEM瀆eʗqGvt[Ť3RHռ,JMQwuUa>R,5=,,w&}c'\me4/#="rV%k[n8Rcv!(.Z$2iUD5r$} VJB KTpB"jO-(dp(8gy@HGA"2(+KR@iTqE؆&eP i A K-L@jqh+{c /,"4"| y(U@3&BQ2@+,>|nOsxFM.tPA9Qp GP!rܬ?<1)*KXmm kc] RzdwlWe!a!<\? gWFF_p, t_.z`0&PZFPfj$(697s%B/M2C!%{NVkCq]@$6 d]m!]/,z$0(T+ˌR,FZ(lG-[oaoђQO9mzFCfX0C:%(,\ %HlS2S8Bx*WGCUx:}u4NώӞ{4.Bmnik!07t"+n> ,ڀn5ce+Jcorlq,[M[!mDQ"Aw@0dS"XsvN,>=+]嬈+<VEG=63Y6;onECa Vȥ 1(1l)oEE5҉e2悊ya˯"j>)hT{S霱wٗ)i\ϻ\.3@So3$%*ȡJKCפZ<['yd~7OPzG5K!5p+!rѵC&QFzKm0ɂ<̼8yL'eyNo;o{6 ۞xmjJ:Ӿr:WʐSzմIOfrS4ݛZMzu]IGs:isuǨ_Z`tt oW`{l6\#6TD#Ҍ~5W*ޣhW2UY}͒IӖvv_gBPpmY&jɵte۱=[5_wikջo'm #bcОhAW_ aKsp/ȿ[q*eZ2ћNNRB%޶9$_}6{5+ki=ogY#%Vb\[նrb[W@SaSnPKmEPK28meta.xml0} j!ɂCJ]m犵'[mM@g(^nmmeH8 @2Ņ<'/ՇBN-HZu0Hc {-0T-jUIB4ȭw^(5gL<>;\SahU0DOpkS]i0C~(}N_,>dq؋Ӏ."8C1A$;BM|bYkwU};kA4GYo@#'!>VV_I$[dnv36]zw.v/CmTPK?ώtPK28Thumbnails/thumbnail.png}Vy4_hB EdM!Kh([P- 0T2c1YdRcyu{],f8D0h` p 2ʏ %ng,=wo.L'cY{Q0/ux3 MP ̀gЂ_We]6^x̃hVOqwߴniIs,]KݴeZ7AurzǧJR`_*z*xN `f$D!ο7]r RH)iF-m^\}n֢jXnXj'(LB[,7d-Z;''KgYL'Lw&& ZBC9]~~:+MՌZ|~4r/Q;?Oy}R026N_tqܮWz>W]xsNĿhݾZySci';P6 mKj)n]|}goTz.z3H"G] R+EY\J/o"tpKBb{T±_8]hE0!M_MgcBFfvNhdzlB^( .$#HQ5 2QEVV&5[K#v%=~cּE9\@3seS) ;ktMQRS&+񣕷ҍ.h.t,lp87YSٽ׸=s`bv2\[ } Yx <^յuĮϚO|zC=l^\J gX5bK3Lk-Med "07}g`ǼN<-iWaQ i9ۓ>[VD앒krɊ sݢ{ iz3'PW;4lޞCrlUh/_dt\VJegpB^6ZE,|Bۧqksd4xWQ3^#U>i4%Wݭ,2L)wvBbxh 0t5TH\Mڛ^"|Z/.1;BFe+iǤ|G[]k*(.Lm,0{*572, |OQUݐZe;wTr9+@0/m}=Fc|@d1QpB |wdw{M-RlG"Ea @c*& .$Ah4Ke\PΗTUjt> dȴ sv5@:vF`͎&w5j5m^\ELfFOY2OJNF6iBa#UW+8p8[r;-}%vgcRAUشf!3c_<Ã,T>qgT?oDHnlEG?Z.]uӪ|GnЫ_#ѝϘ fggǧyʍfjs]۱ә#@U36w!CC:_ (@ 5lIO+rnai b(Bc~[rf%zQPKLK PK28 settings.xmlZ[s6~0}hC0$]!aI7a+F,Jd qg<`Kwn>DRKjGyz"w(}sx(|~@g ɾaCaْ &!WUaqoqorZ<6R U `&d¯OsM[Td."o5zo#RAwh&3gQ eLCn,? Td CяkRS?]Z>,ÂrەrN|t4!2AGţPP'Sx q$56h }X^XE\;hoOEDP])2Pgy }|ޥYBȌRfT*xhk'Mz )u {*~`<xS{.]D/t*h GBeрF]2K+?c-5ӊ暨^0ӢBϠgRݓښpqsvթj$hIʣQ㮭G|hr'`!i"(>l&e38/4- 0 : TlMC`g~pPA5F&λ湏kpqW@\XAFL.} -N\-fj.0f T yb`yʝ뛣V4cՊą0$c.mʛwS<&Bϒ8b<(sT)i]EX|H!_Tʝz18{oIjN7IQׂpqr՛5\AkagMv@|6s-,2O\څ'.?PKANPK28.++mimetypePK28QConfigurations2/statusbar/PK28'Configurations2/accelerator/current.xmlPK28Configurations2/floater/PK28Configurations2/popupmenu/PK28NConfigurations2/progressbar/PK28Configurations2/menubar/PK28Configurations2/toolbar/PK28Configurations2/images/Bitmaps/PK280J: 1content.xmlPK28mE styles.xmlPK28?ώt[meta.xmlPK28LK PThumbnails/thumbnail.pngPK28gEj% settings.xmlPK28AN%META-INF/manifest.xmlPKK'seriation/vignettes/seriation.bib0000644000176200001440000004414213236106744016745 0ustar liggesusersThis file was created with JabRef 2.2. Encoding: ISO8859_1 @INCOLLECTION{seriation:Garfinkel:1985, author = {R. S. Garfinkel}, title = {Motivation and Modeling}, year = {1985}, chapter = {2}, pages = {17--36}, crossref = {seriation:Lawler:1985}, owner = {hahsler}, timestamp = {2007.03.27} } @INCOLLECTION{seriation:Arabie:1996, author = {P. Arabie and L. J. Hubert}, title = {An Overview of Combinatorial Data Analysis}, booktitle = {Clustering and Classification}, publisher = {World Scientific}, year = {1996}, editor = {P. Arabie and L. J. Hubert and G. De Soete}, pages = {5--63}, address = {River Edge, NJ}, owner = {hahsler}, timestamp = {2007.07.04} } @ARTICLE{seriation:Arabie:1990, author = {P. Arabie and L. J. Hubert}, title = {The Bond Energy Algorithm Revisited}, journal = {{IEEE} Transactions on Systems, Man, and Cybernetics}, year = {1990}, volume = {20}, pages = {268--74}, number = {1}, owner = {hahsler}, timestamp = {2007.04.10} } @ARTICLE{seriation:Bar-Joseph:2001, author = {Z. Bar-Joseph and E. D. Demaine and D. K. Gifford and T. Jaakkola}, title = {Fast Optimal Leaf Ordering for Hierarchical Clustering}, journal = {Bioinformatics}, year = {2001}, volume = {17}, pages = {22--29}, number = {1}, owner = {hahsler}, timestamp = {2007.03.27} } @INPROCEEDINGS{seriation:Bertin:1999, author = {J. Bertin}, title = {Graphics and Graphic Information Processing}, booktitle = {Readings in Information Visualization}, year = {1999}, editor = {S. K. Card and J. D. Mackinlay and B. Shneiderman}, pages = {62--65}, address = {San Francisco, CA, USA}, publisher = {Morgan Kaufmann Publishers Inc.}, book = {Readings in Information Visualization: Using Vision to Think}, isbn = {1-55860-533-9} } @BOOK{seriation:Bertin:1981, title = {Graphics and Graphic Information Processing}, publisher = {Walter de Gruyter}, year = {1981}, author = {Bertin, J}, address = {Berlin}, note = {Translated by William J. Berg and Paul Scott}, owner = {hahsler}, timestamp = {2007.04.05} } @ARTICLE{seriation:Brusco:2007, author = {Brusco, M. and K{\"o}hn, H. F. and Stahl, S.}, title = {Heuristic Implementation of Dynamic Programming for Matrix Permutation Problems in Combinatorial Data Analysis}, journal = {Psychometrika}, year = {2008}, volume = {73}, number = {3}, pages = {503--522}, owner = {hahsler}, timestamp = {2007.07.12} } @BOOK{seriation:Brusco:2005, title = {Branch-and-Bound Applications in Combinatorial Data Analysis}, publisher = {Springer}, year = {2005}, author = {Michael Brusco and Stephanie Stahl}, owner = {hahsler}, timestamp = {2007.07.04} } @ARTICLE{seriation:Caraux:2005, author = {Caraux, G. and Pinloche, S.}, title = {Permutmatrix: A Graphical Environment to Arrange Gene Expression Profiles in Optimal Linear Order}, journal = {Bioinformatics}, year = {2005}, volume = {21}, pages = {1280--1281}, number = {7}, owner = {hahsler}, timestamp = {2007.03.19} } @ARTICLE{seriation:Chen:2002, author = {Chun-Houh Chen}, title = {Generalized Association Plots: Information Visualization via Iteratively Generated Correlation Matrices}, journal = {Statistica Sinica}, year = {2002}, volume = {12}, pages = {7--29}, number = {1}, owner = {hahsler}, timestamp = {2007.03.19} } @MANUAL{seriation:Chessel:2007, title = {\pkg{ade4}: Analysis of Ecological Data : Exploratory and Euclidean methods in Multivariate data analysis and graphical display}, author = {Daniel Chessel and Anne-Beatrice Dufour and Stephane Dray}, year = {2007}, note = {R package version 1.4-3}, url = {http://CRAN.R-project.org/package=ade4}, owner = {hahsler}, timestamp = {2007.08.07} } @article{seriation:Dray:2007, author = "Stephane Dray and Anne-Beatrice Dufour", title = "The ade4 Package: Implementing the Duality Diagram for Ecologists", journal = "Journal of Statistical Software", volume = "22", number = "4", day = "4", month = "6", year = "2007", URL = "http://www.jstatsoft.org/v22/i04", } @ARTICLE{seriation:Eisen:1998, author = {Michael B. Eisen and Paul T. Spellman and Patrick O. Browndagger and David Botstein}, title = {Cluster Analysis and Display of Genome-wide Expression Patterns}, journal = {Proceedings of the National Academy of Science of the United States}, year = {1998}, volume = {95}, pages = {14863--14868}, number = {25}, month = {December}, owner = {hahsler}, timestamp = {2007.04.05} } @INPROCEEDINGS{seriation:Falguerolles:1997, author = {Antoine de Falguerolles and Felix Friedrich and G{\"u}nther Sawitzki}, title = {A Tribute to {J}. {B}ertin's Graphical Data Analysis}, booktitle = {SoftStat '97 (Advances in Statistical Software 6)}, year = {1997}, editor = {W. Bandilla and F. Faulbaum}, pages = {11--20}, publisher = {Lucius \& Lucius}, owner = {hahsler}, timestamp = {2007.02.22} } @ARTICLE{seriation:Gale:1984, author = {N. Gale and W. C. Halperin and C. M. Costanzo}, title = {Unclassed Matrix Shading and Optimal Ordering in Hierarchical Cluster Analysis}, journal = {Journal of Classification}, year = {1984}, volume = {1}, pages = {75--92}, owner = {hahsler}, timestamp = {2007.04.06} } @ARTICLE{seriation:Gruvaeus:1972, author = {Gruvaeus, G. and Wainer, H.}, title = {Two Additions to Hierarchical Cluster Analysis}, journal = {British Journal of Mathematical and Statistical Psychology}, year = {1972}, volume = {25}, pages = {200--206}, owner = {hahsler}, timestamp = {2007.03.27} } @MANUAL{seriation:Hahsler:2007b, title = {\pkg{TSP}: Traveling Salesperson Problem (TSP)}, author = {Michael Hahsler and Kurt Hornik}, year = {2007}, url = {http://CRAN.R-project.org/package=TSP}, note = {R package version 0.2-2} } @ARTICLE{seriation:Hahsler:2007, AUTHOR = {Michael Hahsler and Kurt Hornik}, TITLE = {{TSP} -- {I}nfrastructure for the Traveling Salesperson Problem}, JOURNAL = {Journal of Statistical Software}, YEAR = {2007}, VOLUME = {23}, PAGES = {1-21}, NUMBER = {2}, MONTH = {December}, URL = "http://www.jstatsoft.org/v23/i02", } @BOOK{seriation:Hartigan:1975, title = {Clustering Algorithms}, publisher = {Wiley}, year = {1975}, author = {John A. Hartigan}, owner = {hahsler}, timestamp = {2007.04.10} } @ARTICLE{seriation:Hartigan:1967, author = {J. A. Hartigan}, title = {Representation of Similarity Matrices by Trees}, journal = {Journal of the American Statistical Association}, year = {1967}, volume = {62}, pages = {1140--1158}, number = {320}, owner = {hahsler}, timestamp = {2007.04.10} } @ARTICLE{seriation:Held:1962, author = {M. Held and R. M. Karp}, title = {A Dynamic Programming Approach to Sequencing Problems}, journal = {Journal of {SIAM}}, year = {1962}, volume = {10}, pages = {196--210}, owner = {hahsler}, timestamp = {2007.03.27} } @ARTICLE{seriation:Hubert:1974, author = {L. J. Hubert}, title = {Some Applications of Graph Theory and Related Nonmetric Techniques to Problems of Approximate Seriation: The Case of Symmetric Proximity Measures}, journal = {British Journal of Mathematical Statistics and Psychology}, year = {1974}, volume = {27}, pages = {133--153}, owner = {hahsler}, timestamp = {2007.03.26} } @BOOK{seriation:Hubert:2001, title = {Combinatorial Data Analysis: Optimization by Dynamic Programming}, publisher = {Society for Industrial Mathematics}, year = {2001}, author = {Lawrence Hubert and Phipps Arabie and Jacqueline Meulman}, owner = {hahsler}, timestamp = {2007.07.04} } @ARTICLE{seriation:Hubert:1981, author = {L. J. Hubert and R. G. Golledge}, title = {Matrix Reorganization and Dynamic Programming: Applications to Paired Comparisons and Unidimensional Seriation}, journal = {Psychometrika}, year = {1981}, volume = {46}, pages = {429--441}, number = {4}, owner = {hahsler}, timestamp = {2007.03.26} } @MANUAL{seriation:Hurley:2007, title = {\pkg{gclus}: Clustering Graphics}, author = {Catherine Hurley}, year = {2007}, url = {http://CRAN.R-project.org/package=gclus}, note = {R package version 1.2} } @INPROCEEDINGS{seriation:Ihm:2005, author = {Peter Ihm}, title = {A Contribution to the History of Seriation in Archaeology}, booktitle = {Classification - the Ubiquitous Challenge, Proceedings of the 28th Annual Conference of the Gesellschaft f{\"u}r Klassifikation e.V., University of Dortmund, March 9--11, 2004}, year = {2005}, editor = {Weihs, Claus and Gaul, Wolfgang}, series = {Studies in Classification, Data Analysis, and Knowledge Organization}, pages = {307--316} } @INCOLLECTION{seriation:Kendall:1971, author = {Kendall, D. G.}, title = {Seriation from Abundance Matrices}, booktitle = {Mathematics in the Archaeological and Historical Sciences}, year = {1971}, editor = {F.R. Hodson and D.G. Kendall and P. Tautu}, pages = {214--252}, owner = {hahsler}, timestamp = {2007.03.19} } @INCOLLECTION{seriation:Leeuw:2005, author = {Jan de Leeuw}, title = {Unidimensional Scaling}, booktitle = {Encyclopedia of Statistics in Behavioral Science}, publisher = {Wiley}, year = {2005}, editor = {B.S. Everitt and D.C. Howelll}, volume = {4}, owner = {hahsler}, timestamp = {2007.03.19} } @ARTICLE{seriation:Lenstra:1974, author = {J. K. Lenstra}, title = {Clustering a Data Array and the Traveling-Salesman Problem}, journal = {Operations Research}, year = {1974}, volume = {22}, pages = {413--414}, number = {2}, owner = {hahsler}, timestamp = {2007.04.16} } @ARTICLE{seriation:Lin:1973, author = {S. Lin and B. W. Kernighan}, title = {An Effective Heuristic Algorithm for the Traveling-Salesman Problem}, journal = {Operations Research}, year = {1973}, volume = {21}, pages = {498--516}, number = {2}, owner = {hahsler}, timestamp = {2007.03.27} } @ARTICLE{seriation:Ling:1973, author = {Robert L. Ling}, title = {A Computer Generated Aid for Cluster Analysis}, journal = {Communications of the {ACM}}, year = {1973}, volume = {16}, pages = {355--361}, number = {6}, address = {New York, NY, USA}, publisher = {ACM Press} } @ARTICLE{seriation:Marcotorchino:1987, author = {F. Marcotorchino}, title = {Block Seriation Problems: A Unified Approach}, journal = {Applied Stochastic Models and Data Analysis}, year = {1987}, volume = {3}, pages = {73--91}, owner = {hahsler}, timestamp = {2007.04.17} } @ARTICLE{seriation:McCormick:1972, author = {William T. McCormick and Paul J. Schweitzer and Thomas W. White}, title = {Problem Decomposition and Data Reorganization by a Clustering Technique}, journal = {Operations Research}, year = {1972}, volume = {20}, pages = {993--1009}, number = {5}, owner = {hahsler}, timestamp = {2007.04.10} } @MANUAL{seriation:Meyer:2007, title = {\pkg{proxy}: Distance and Similarity Measures}, author = {David Meyer and Christian Buchta}, year = {2007}, url = "http://CRAN.R-project.org/package=proxy", note = {R package version 0.1} } @BOOK{seriation:Murtagh:1985, title = {Multidimensional Clustering Algorithms}, publisher = {Physica-Verlag}, year = {1985}, author = {Fionn Murtagh}, volume = {4}, series = {Compstat Lectures}, address = {Vienna}, owner = {hahsler}, timestamp = {2007.04.10} } @ARTICLE{seriation:Niermann:2005, author = {Niermann, Stefan}, title = {Optimizing the Ordering of Tables With Evolutionary Computation}, journal = {The American Statistician}, year = {2005}, volume = {59}, pages = {41--46}, number = {1}, owner = {hahsler}, timestamp = {2007.03.16} } @MANUAL{seriation:Oksanen:2007, title = {\pkg{vegan}: Community Ecology Package}, author = {Jari Oksanen and Roeland Kindt and Pierre Legendre and Bob O'Hara}, year = {2007}, note = {R package version 1.8-6}, owner = {hahsler}, url = {http://CRAN.R-project.org/package=vegan}, timestamp = {2007.08.07} } @ARTICLE{seriation:Padberg:1990, author = {M. Padberg and G. Rinaldi}, title = {Facet Identification for the Symmetric Traveling Salesman Polytope}, journal = {Mathematical Programming}, year = {1990}, volume = {47}, pages = {219--257}, number = {2}, address = {Secaucus, NJ, USA}, issn = {0025-5610}, owner = {hahsler}, publisher = {Springer-Verlag New York, Inc.}, timestamp = {2007.03.27} } @ARTICLE{seriation:Petrie:1899, author = {Petrie, F. W. M.}, title = {Sequences in Prehistoric Remains}, journal = {Journal of the Anthropological Institute}, year = {1899}, volume = {29}, pages = {295--301}, owner = {hahsler}, timestamp = {2007.03.19} } @ARTICLE{seriation:Robinson:1951, author = {W. S. Robinson}, title = {A Method for Chronologically Ordering Archaeological Deposits}, journal = {American Antiquity}, year = {1951}, volume = {16}, pages = {293--301}, owner = {hahsler}, timestamp = {2007.03.19} } @ARTICLE{seriation:Rosenkrantz:1977, author = {Daniel J. Rosenkrantz and Richard E. Stearns and Philip M. Lewis, II}, title = {An Analysis of Several Heuristics for the Traveling Salesman Problem}, journal = {{SIAM} Journal on Computing}, year = {1977}, volume = {6}, pages = {563--581}, number = {3}, owner = {hahsler}, timestamp = {2007.03.27} } @ARTICLE{seriation:Rousseeuw:1987, author = {Rousseeuw, P. J.}, title = {Silhouettes: A Graphical Aid to the Interpretation and Validation of Cluster Analysis}, journal = {Journal of Computational and Applied Mathematics}, year = {1987}, volume = {20}, pages = {53--65}, number = {1}, owner = {hahsler}, timestamp = {2007.04.10} } @BOOK{seriation:Sneath:1973, title = {Numerical Taxonomy}, publisher = {Freeman and Company}, year = {1973}, author = {Peter H. A. Sneath and Robert R. Sokal}, address = {San Francisco}, owner = {hahsler}, timestamp = {2007.04.06} } @ARTICLE{seriation:Strehl:2003, author = {Strehl, A. and Ghosh, J.}, title = {Relationship-based Clustering and Visualization for High-dimensional Data Mining}, journal = {{INFORMS} Journal on Computing}, year = {2003}, volume = {15}, pages = {208--230}, number = {2}, owner = {hahsler}, timestamp = {2007.04.10} } @BOOK{seriation:Gutin:2002, title = {The Traveling Salesman Problem and Its Variations}, publisher = {Kluwer}, year = {2002}, editor = {G. Gutin and A. P. Punnen}, volume = {12}, series = {Combinatorial Optimization}, address = {Dordrecht}, owner = {hahsler}, timestamp = {2006.11.29} } @BOOK{seriation:Lawler:1985, title = {The Traveling Salesman Problem}, publisher = {Wiley}, year = {1985}, editor = {Lawler, E. L. and Lenstra, J. K. and Rinnooy Kan, A. H. G. and Shmoys, D. B.}, address = {New York}, owner = {hahsler}, timestamp = {2007.03.27} } @Book{seriation:Fowler:2004, author = {Martin Fowler}, title = {UML Distilled: A Brief Guide to the Standard Object Modeling Language}, publisher = {Addison-Wesley Professional}, edition = {third}, year = 2004, } @article{seriation:Jurman:2008, author = {Jurman, Giuseppe and Merler, Stefano and Barla, Annalisa and Paoli, Silvano and Galea, Antonio and Furlanello, Cesare }, journal = {Bioinformatics}, month = {January}, number = {2}, pages = {258--264}, priority = {3}, title = {Algebraic Stability Indicators for Ranked Lists in Molecular Profiling}, volume = {24}, year = {2008} } @Manual{seriation:Hornik+Meyer:2008, title = {\pkg{relations}: Data Structures and Algorithms for Relations}, author = {Kurt Hornik and David Meyer}, year = {2008}, url = {http://CRAN.R-project.org/package=relations}, note = {R package version 0.3-1}, } @article{seriation:Hahsler+Hornik:2008, author = {Michael Hahsler and Kurt Hornik and Christian Buchta}, title = {Getting Things in Order: An Introduction to the {R} Package seriation}, journal = {Journal of Statistical Software}, year = {2008}, volume = {25}, pages = {1--34}, number = {3}, month = {March}, issn = {1548-7660}, url = {http://www.jstatsoft.org/v25/i03}, } @article{seriation:Hahsler+Kornik:2011, author = {Michael Hahsler and Kurt Hornik}, title = {Dissimilarity Plots: {A} Visual Exploration Tool for Partitional Clustering}, journal = {Journal of Computational and Graphical Statistics}, year = {2011}, volume = {10}, number = {2}, pages = {335--354}, } @article{hahsler:Hahsler2016d, author = {Michael Hahsler}, title = {An Experimental Comparison of Seriation Methods For One-Mode Two-Way Data}, journal = {European Journal of Operational Research}, year = {2017}, volume = {257}, pages = {133--143}, number = {}, month = {February}, } @INPROCEEDINGS{seriation:Ding:2004, author = {Chris Ding and Xiaofeng He}, title = {Linearized cluster assignment via spectral ordering}, booktitle = {Proceedings of the Twenty-first International Conference on Machine Learning (ICML '04)}, year = {2004}, pages = {30}, publisher = {ACM Press} } @INBOOK{seriation:Burkard:1998, author = {Rainer E. Burkard and Eranda Cela and Panos M. Pardalos and Leonidas S. Pitsoulis}, title = {The Quadratic Assignment Problem}, year = {1998}, booktitle = {Handbook of Combinatorial Optimization}, editor = {P. Pardalos and D.-Z. Du}, publisher = {Springer Verlag} } @inproceedings{seriation:Barnard:1993, author = {Barnard, S. T. and Pothen, A. and Simon, H. D.}, title = {A Spectral Algorithm for Envelope Reduction of Sparse Matrices}, booktitle = {Proceedings of the 1993 ACM/IEEE Conference on Supercomputing}, series = {Supercomputing '93}, year = {1993}, location = {Portland, Oregon, USA}, pages = {493--502}, publisher = {ACM}, address = {New York, NY, USA}, } @article {seriation:Hubert:1976, author = {Hubert, Lawrence and Schultz, James}, title = {Quadratic Assignment as a General Data Analysis Strategy}, journal = {British Journal of Mathematical and Statistical Psychology}, volume = {29}, number = {2}, publisher = {Blackwell Publishing Ltd}, issn = {2044-8317}, pages = {190--241}, year = {1976}, } seriation/vignettes/seriation.Rnw0000644000176200001440000024054614456107274016771 0ustar liggesusers\documentclass[nojss]{jss} \usepackage[english]{babel} %\documentclass[fleqn, a4paper]{article} %\usepackage{a4wide} %\usepackage[round,longnamesfirst]{natbib} %\usepackage{graphicx,keyval,thumbpdf,url} %\usepackage{hyperref} %\usepackage{Sweave} \SweaveOpts{strip.white=true} \AtBeginDocument{\setkeys{Gin}{width=0.6\textwidth}} \usepackage[utf8]{inputenc} %% end of declarations %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \usepackage{amsmath} \usepackage{amsfonts} %\newcommand{\strong}[1]{{\normalfont\fontseries{b}\selectfont #1}} \newcommand{\class}[1]{\mbox{\textsf{#1}}} \newcommand{\func}[1]{\mbox{\texttt{#1()}}} %\newcommand{\code}[1]{\mbox{\texttt{#1}}} %\newcommand{\pkg}[1]{\strong{#1}} \newcommand{\samp}[1]{`\mbox{\texttt{#1}}'} %\newcommand{\proglang}[1]{\textsf{#1}} \newcommand{\set}[1]{\mathcal{#1}} \newcommand{\sQuote}[1]{`{#1}'} \newcommand{\dQuote}[1]{``{#1}''} \newcommand\R{{\mathbb{R}}} \DeclareMathOperator*{\argmin}{argmin} \DeclareMathOperator*{\argmax}{argmax} %% almost as usual \author{Michael Hahsler\\Southern Methodist University \And Kurt Hornik\\Wirtschaftsuniversit\"at Wien \AND Christian Buchta\\Wirtschaftsuniversit\"at Wien} \title{Getting Things in Order:\\ An Introduction to the \proglang{R}~Package~\pkg{seriation}} %% for pretty printing and a nice hypersummary also set: \Plainauthor{Michael Hahsler, Kurt Hornik, Christian Buchta} %% comma-separated \Plaintitle{Getting Things in Order: An Introduction to the R Package seriation} %% without formatting \Shorttitle{Getting Things in Order} %% a short title (if necessary) %% an abstract and keywords \Abstract{Seriation, i.e., finding a suitable linear order for a set of objects given data and a loss or merit function, is a basic problem in data analysis. Caused by the problem's combinatorial nature, it is hard to solve for all but very small sets. Nevertheless, both exact solution methods and heuristics are available. In this paper we present the package~\pkg{seriation} which provides an infrastructure for seriation with \proglang{R}. The infrastructure comprises data structures to represent linear orders as permutation vectors, a wide array of seriation methods using a consistent interface, a method to calculate the value of various loss and merit functions, and several visualization techniques which build on seriation. To illustrate how easily the package can be applied for a variety of applications, a comprehensive collection of examples is presented.} \Keywords{combinatorial data analysis, seriation, permutation, \proglang{R}} \Plainkeywords{combinatorial data analysis, seriation, permutation, R} %% without formatting \Address{ Michael Hahsler\\ Engineering Management, Information, and Systems\\ Lyle School of Engineering\\ Southern Methodist University\\ P.O. Box 750123 \\ Dallas, TX 75275-0123\\ E-mail: \email{mhahsler@lyle.smu.edu}\\ URL: \url{http://lyle.smu.edu/~mhahsler} Kurt Hornik\\ Department f\"ur Statistik \& Mathematik\\ Wirtschaftsuniversit\"at Wien\\ 1090 Wien, Austria\\ E-mail: \email{kurt.hornik@wu.ac.at}\\ URL: \url{http://statmath.wu.ac.at/~hornik/} Christian Buchta\\ Department f\"ur Welthandel\\ Wirtschaftsuniversit\"at Wien\\ 1090 Wien, Austria\\ E-mail: \email{christian.buchta@wu.ac.at}\\ URL: \url{http://www.wu.ac.at/itf/institute/staff/buchta} } \hyphenation{Brusco} \sloppy %% \VignetteIndexEntry{An Introduction to the R package seriation} \begin{document} %\title{Getting Things in Order: An introduction to the %R~package~\pkg{seriation}} %\author{Michael Hahsler, Kurt Hornik and Christian Buchta} \maketitle %\abstract{Seriation, i.e., finding a suitable linear order for a set of % objects given data and a loss or merit function, is a basic problem in % data analysis. Caused by the problem's combinatorial nature, it is % hard to solve for all but very small sets. Nevertheless, both exact % solution methods and heuristics are available. In this paper we % present the package~\pkg{seriation} which provides an infrastructure % for seriation with \proglang{R}. The infrastructure comprises data % structures to represent linear orders as permutation vectors, a wide % array of seriation methods using a consistent interface, a method to % calculate the value of various loss and merit functions, and several % visualization techniques which build on seriation. To illustrate how % easily the package can be applied for a variety of applications, a % comprehensive collection of examples is presented.} % <>= options(scipen=3, digits=4) ### for sampling set.seed(1234) @ \section{Introduction} A basic problem in data analysis, called \emph{seriation} or sometimes \emph{sequencing}, is to arrange all objects in a set in a linear order given available data and some loss or merit function in order to reveal structural information. Together with cluster analysis and variable selection, seriation is an important problem in the field of \emph{combinatorial data analysis}~\citep{seriation:Arabie:1996}. Solving problems in combinatorial data analysis requires the solution of discrete optimization problems which, in the most general case, involves evaluating all feasible solutions. Due to the combinatorial nature, the number of possible solutions grows with problem size (number of objects, $n$) by the order~$O(n!)$. This makes a brute-force enumerative approach infeasible for all but very small problems. To solve larger problems (currently with up to 40 objects), partial enumeration methods can be used. For example, \cite{seriation:Hubert:2001} propose dynamic programming and \cite{seriation:Brusco:2005} use a branch-and-bound strategy. For even larger problems only heuristics can be employed. It has to be noted that seriation has a rich history in archaeology. \cite{seriation:Petrie:1899} was the first to use seriation as a formal method. He applied it to find a chronological order for graves discovered in the Nile area given objects found there. He used a cross-tabulation of grave sites and objects and rearranged the table using row and column permutations till all large values were close to the diagonal. In the rearranged table graves with similar objects are closer to each other. Together with the assumption that different objects continuously come into and go out of fashion, the order of graves in the rearranged table suggests a chronological order. Initially, the rearrangement of rows and columns of this contingency table was done manually and the adequacy was only judged subjectively by the researcher. Later, \cite{seriation:Robinson:1951}, \cite{seriation:Kendall:1971} and others proposed measures of agreement between rows to quantify optimality of the resulting table. A comprehensive description of the development of seriation in archeology is presented by \cite{seriation:Ihm:2005}. Techniques related to seriation are also popular in several other fields. Especially in ecology scaling techniques are used under the name \emph{ordination}. For these applications several \proglang{R} packages already exist (e.g., \pkg{ade4}~\citep{seriation:Chessel:2007,seriation:Dray:2007} and \pkg{vegan}~\citep{seriation:Oksanen:2007}). This paper describes the new package \pkg{seriation} which differs from existing packages in the following ways: \begin{itemize} \item \pkg{seriation} provides a flexible infrastructure for seriation; \item \pkg{seriation} focuses on seriation as a combinatorial optimization problem. \end{itemize} This paper starts with a formal introduction of the seriation problem as a combinatorial optimization problem in Section~\ref{sec:seriation}. In Section~\ref{sec:methods} we give an overview of seriation methods. In Section~\ref{sec:infrastructure} we present the infrastructure provided by the package~\pkg{seriation}. Several examples and applications for seriation are given in Section~\ref{sec:example}. Section~\ref{sec:conclusion} concludes. A previous version of this manuscript was published in the \emph{Journal of Statistical Software} \citep{seriation:Hahsler+Hornik:2008}. \section{Seriation as a combinatorial optimization problem} \label{sec:seriation} To seriate a set of $n$ objects $\{O_1,\dots,O_n\}$ one typically starts with an $n \times n$ symmetric dissimilarity matrix~$\mathbf{D} = (d_{ij})$ where $d_{ij}$ for $1 \le i,j \le n$ represents the dissimilarity between objects $O_i$ and $O_j$, and $d_{ii} = 0$ for all~$i$. We define a permutation function $\Psi$ as a function which reorders the objects in $\mathbf{D}$ by simultaneously permuting rows and columns. The seriation problem is to find a permutation function $\Psi^*$ %$\{1,\dots,n\} \rightarrow \{1,\dots,n\}$, i.e. a %bijection that maps the set of indices of the objects (and equally of rows and %columns of $\mathbf{D}$) onto itself, which optimizes the value of a given loss function~$L$ or merit function~$M$. This results in the optimization problems \begin{equation} \Psi^* = \argmin_\Psi L(\Psi(\mathbf{D})) \quad \text{or} \quad \Psi^* = \argmax_\Psi M(\Psi(\mathbf{D})), \end{equation} respectively. %This is clearly a hard discrete optimization problem since the number of %possible permutations is $n!$ which makes an exhaustive %search for sets with a medium to large number of objects infeasible. %Partial enumeration methods and heuristics can be used. Such methods are %presented in Section~\ref{sec:methods}. %But first, we review commonly used loss functions in the following section. %\marginpar{two-mode data missing} A symmetric dissimilarity matrix is known as \emph{two-way one-mode} data since it has columns and rows (two-way) but only represents one set of objects (one-mode). Seriation is also possible for two-way two-mode data which are represented by a general nonnegative matrix. In such data columns and rows represent two sets of objects which are reordered simultaneously. For loss/merit functions for two-way two-mode data the optimal order of columns can depend of the order of rows and vice versa or it can be independent allowing for breaking the optimization down into two separate problems, one for the columns and one for the rows. Another way to deal with the seriation for two-way two-mode data is to calculate two dissimilarity matrices, one for each mode, and then solve two seriation problems for two-way one-mode data. Furthermore, seriation can be generalized to $k$-way $k$-mode data in the form of a $k$-dimensional array by defining suitable loss/merit functions for such data or by breaking the problem down into several lower dimensional independent problems. To assess the complexity of seriation of $k$-way $k$-mode data, let us assume the data is a $k$-dimensional array with the dimensions containing $n_1, n_2, \ldots, n_k$ objects. If the loss/merit function allows for separating the problem into $k$ independent problems, the problem size is just the sum of the individual problems. By using complete enumeration the size is $O(\sum_{i=1}^k{n_i!})$. If the problem is not separable and the optimal seriation of each dimension depends on the order of the objects of the other dimensions, the problem size is $O((\sum_{i=1}^k{n_i})!)$. For example for $k=5$ and all dimensions containing 5 objects, the search space for separable dimensions is only 600 while without separability it is larger than $10^{25}$ clearly too big to be solvable in reasonable time. This shows that for data with even only a few dimensions and a few objects each, finding the optimal solution is infeasible and loss/merit functions which allow for separating the problem are highly desirable. In the following subsections, we review some commonly employed loss/merit functions. Most functions are used for two-way one-mode data but the measure of effectiveness and stress can be also used for two-way two-mode data. For the implementation of various loss or merit measures see function~\func{criterion} in Section~\ref{sec:infrastructure}. %\section{Loss functions} %\label{sec:criteria} %In the literature several loss functions are suggested. %We review the most commonly used functions. \subsection{Column/row gradient measures} A symmetric dissimilarity matrix where the values in all rows and columns only increase when moving away from the main diagonal is called a perfect \emph{anti-Robinson matrix} after the statistician \cite{seriation:Robinson:1951}. Formally, an $n \times n$ dissimilarity matrix $\mathbf{D}$ is in anti-Robinson form if and only if the following two gradient conditions hold~\citep{seriation:Hubert:2001}: \begin{align} \text{within rows:} & \quad d_{ik} \le d_{ij} \quad \text{for} \quad 1 \le i < k < j \le n; \\ \text{within columns:} & \quad d_{kj} \le d_{ij} \quad \text{for} \quad 1 \le i < k < j \le n. \end{align} In an anti-Robinson matrix the smallest dissimilarity values appear close to the main diagonal, therefore, the closer objects are together in the order of the matrix, the higher their similarity. This provides a natural objective for seriation. It has to be noted that $\mathbf{D}$ can be brought into a perfect anti-Robinson form by row and column permutation whenever $\mathbf{D}$ is an ultrametric or $\mathbf{D}$ has an exact Euclidean representation in a single dimension~\citep{seriation:Hubert:2001}. However, for most data only an approximation to the anti-Robinson form is possible. A suitable merit measure which quantifies the divergence of a matrix from the anti-Robinson form was given by \cite{seriation:Hubert:2001} as \begin{equation} M(\mathbf{D}) = \sum_{i y. \end{cases} \end{equation} It results in the raw number of triples satisfying the gradient constraints minus triples which violate the constraints. The second function is defined as: \begin{equation} f(z,y) = |y-z|\mathrm{sign}(y-z) = y-z \end{equation} It weighs each satisfaction or violation by its magnitude given by the absolute difference between the values. \subsection{Anti-Robinson events} An even simpler loss function can be created in the same way as the gradient measures above by concentrating on violations only. \begin{equation} L(\mathbf{D}) = \sum_{i y \quad \text{and} \\ 0 \quad \text{otherwise.} \end{cases} \end{equation} $I(\cdot)$ is an indicator function returning $1$ only for violations. \cite{seriation:Chen:2002} presented a formulation for an equivalent loss function and called the violations \emph{anti-Robinson events}. \cite{seriation:Chen:2002} also introduced a weighted versions of the loss function resulting in \begin{equation} f(z, y) = |y-z|I(z, y) \end{equation} using the absolute deviations as weights. \subsection{Hamiltonian path length} The dissimilarity matrix $\mathbf{D}$ can be represented as a finite weighted graph $G = (\Omega,E)$ where the set of objects~$\Omega$ constitute the vertices and each edge~$e_{ij} \in E$ between the objects $O_i, O_j \in \Omega$ has a weight~$w_{ij}$ associated which represents the dissimilarity~$d_{ij}$. Such a graph can be used for seriation~\citep[see, e.g.,][]{seriation:Hubert:1974,seriation:Caraux:2005}. An order~$\Psi$ of the objects can be seen as a path through the graph where each node is visited exactly once, i.e., a Hamiltonian path. Minimizing the Hamiltonian path length results in a seriation optimal with respect to dissimilarities between neighboring objects. The loss function based on the Hamiltonian path length is: \begin{equation} L(\mathbf{D}) = \sum_{i=1}^{n-1} d_{i,i+1}. \end{equation} Note that the length of the Hamiltonian path is equal to the value of the \emph{minimal span loss function} \citep[as used by][]{seriation:Chen:2002}, and both notions are related to the \emph{traveling salesperson problem}~\citep{seriation:Gutin:2002}. \subsection{Inertia criterion} Another way to look at the seriation problem is not to focus on placing small dissimilarity values close to the diagonal, but to push large values away from it. A function to quantify this is the moment of inertia of dissimilarity values around the diagonal \citep{seriation:Caraux:2005} defined as \begin{equation} M(\mathbf{D}) = \sum_{i=1}^n \sum_{j=1}^n d_{ij}|i-j|^2. \end{equation} $|i-j|^2$ is used as a measure for the distance to the diagonal and $d_{ij}$ gives the weight. This is a merit function since the sum increases when higher dissimilarity values are placed farther away from the diagonal. \subsection{Least squares criterion} Another natural loss function for seriation is to quantify the deviations between the dissimilarities in $\mathbf{D}$ and the rank differences of the objects. Such deviations can be measured, e.g, by the sum of squares of deviations \citep{seriation:Caraux:2005} defined by \begin{equation} L(\mathbf{D}) = \sum_{i=1}^n \sum_{j=1}^n (d_{ij} - |i-j|)^2, \end{equation} where $|i-j|$ is the rank difference or gap between $O_i$ and $O_j$. The least squares criterion defined here is related to uni-dimensional scaling~\citep{seriation:Leeuw:2005}, where the objective is to place all $n$ objects on a straight line using a position vector~$\mathbf{z} = z_1,z_2,\ldots,z_n$ such that the dissimilarities in $\mathbf{D}$ are preserved by the relative positions in the best possible way. The optimization problem of uni-dimensional scaling is to find the position vector~$\mathbf{z^*}$ which minimizes $\sum_{i=1}^n \sum_{j=1}^n (d_{ij} - |z_i-z_j|)^2$. This is close to the seriation problem, but in addition to the ranking of the objects also takes the distances between objects on the resulting scale into account. Note that if Euclidean distance is used to calculate $\mathbf{D}$ from a data matrix~$\mathbf{X}$, using the order of the elements in $\mathbf{X}$ as they occur projected on the first principal component of $\mathbf{X}$ minimizes the loss function of uni-dimensional scaling (using squared distances). Using this order, also provides a good solution for the least square seriation criterion. \subsection{Linear Seriation Criterion} The Linear Seriation Criterion (Hubert and Schultz 1976) weights the distances with the absolute rank differences. $$L(\mathbf{D}) \sum_{i=1}^n \sum_{j=1}^n d_{ij} (-|i-j|)$$ \subsection{2-Sum Problem} The 2-Sum loss criterion \citep{seriation:Barnard:1993} multiplies the similarity between objects with the squared rank differences. $$L(\mathbf{D}) \sum_{i,j=1}^p \frac{1}{1+d_{ij}} (i-j)^2,$$ where $s_{ij} = \frac{1}{1+d_{ij}}$ represents the similarity between objects $i$ and $j$. \subsection{Measure of effectiveness} \label{sec:ME} \cite{seriation:McCormick:1972} defined the \emph{measure of effectiveness (ME)} for an $n \times m$ matrix~$\mathbf{X} = (x_{ij})$ as \begin{equation} M(\mathbf{X}) = \frac{1}{2} \sum_{i=1}^{n} \sum_{j=1}^{m} x_{ij}[x_{i,j+1}+x_{i,j-1}+ x_{i+1,j}+x_{i-1,j}] \label{equ:ME} \end{equation} with, by convention $x_{0,j}=x_{n+1,j}=x_{i,0}=x_{i,m+1}=0$. ME is maximized if each element is as closely related numerically to its four neighboring elements as possible. ME was developed for two-way two-mode data, however, ME can also be used for a symmetric matrix (one-mode data) and gets maximal only if all large values are grouped together around the main diagonal. Note that the definition in equation~(\ref{equ:ME}) can be rewritten as \begin{equation} M(\mathbf{X}) = \frac{1}{2} \sum_{i=1}^{n} \sum_{j=1}^{m} x_{ij}[x_{i,j+1}+x_{i,j-1}] + \sum_{i=1}^{n} \sum_{j=1}^{m} x_{ij}[x_{i+1,j}+x_{i-1,j}] \end{equation} showing that the contributions of column and row order to the merit function are independent. \subsection{Stress} \label{sec:stress} Stress measures the conciseness of the presentation of a matrix (two-mode data) and can be seen as a purity function which compares the values in a matrix with their neighbors. The stress measures used here are computed as the sum of squared distances of each matrix entry from its adjacent entries. \cite{seriation:Niermann:2005} defined for an $n \times m$ matrix~$\mathbf{X} = (x_{ij})$ two types of neighborhoods: \begin{itemize} \item The Moore neighborhood comprises the (at most) eight adjacent entries. The local stress measure for element~$x_{ij}$ is defined as \begin{equation} \sigma_{ij} = \sum_{k=\max(1,i-1)}^{\min(n,i+1)} \sum_{l=\max(1,j-1)}^{\min(m,j+1)} (x_{ij} - x_{kl})^2 \end{equation} \item The Neumann neighborhood comprises the (at most) four adjacent entries resulting in the local stress of $x_{ij}$ of \begin{equation} \sigma_{ij} = \sum_{k=\max(1,i-1)}^{\min(n,i+1)} (x_{ij} - x_{kj})^2 + \sum_{l=\max(1,j-1)}^{\min(m,j+1)} (x_{ij} - x_{il})^2 %(x_{ij} - x(i-1,j))^2 + (x_{ij} - x(i+1,j))^2 + %(x_{ij} - x(i,j-1))^2 + (x_{ij} - x(i,j+1))^2 \end{equation} \end{itemize} Both local stress measures can be used to construct a global measure for the whole matrix by summing over all entries which can be used as a loss function: \begin{equation} L(\mathbf{X}) = \sum_{i=1}^n \sum_{j=1}^m \sigma_{ij} \end{equation} The major difference between the Moore and the Neumann neighborhood is that for the later the contributions of row and column order to stress are independent. Stress can be also used as a loss function for symmetric proximity matrices (one-mode data). %, %since it can only be optimal, if large values are %concentrated around the main diagonal. Note also, that stress with Neumann neighborhood is related to the measure of effectiveness defined above (in Section~\ref{sec:ME}) since both measures are optimal if for each cell the cell and its four neighbors are numerically as similar as possible. \section{Seriation methods} \label{sec:methods} Solving the discrete optimization problem for seriation with most loss/merit functions is clearly very hard. The number of possible permutations for $n$ objects is $n!$ which makes an exhaustive search for sets with a medium to large number of objects infeasible. In this section, we describe some methods (partial enumeration, heuristics and other methods) which are typically used for seriation. For each method we state for which type of loss/merit functions it is suitable and whether it finds the optimum or is a heuristic. For the implementation of various seriation methods see function~\func{seriate} in Section~\ref{sec:infrastructure}. \subsection{Partial enumeration methods} Partial enumeration methods search for the exact solution of a combinatorial optimization problem. Exploiting properties of the search space, only a subset of the enormous number of possible combinations has to be evaluated. Popular partial enumeration methods which are used for seriation are \emph{dynamic programming}~\citep{seriation:Hubert:2001} and \emph{branch-and-bound}~\citep{seriation:Brusco:2005}. Dynamic programming recursively searches for the optimal solution checking and storing $2^n-1$ results. Although $2^n-1$ grows at a lower rate than $n!$ and is for $n \gg 3$ considerably smaller, the storage requirements of $2^n-1$ results still grow fast, limiting the maximal problem size severely. For example, for $n=30$ more than one billion results have to be calculated and stored, clearly a number too large for the main memory capacity of most current computers. Branch-and-bound has only very moderate storage requirements. The forward-branching procedure~\citep{seriation:Brusco:2005} starts to build partial permutations from left (first position) to right. At each step, it is checked if the permutation is valid and several fathoming tests are performed to check if the algorithm should continue with the partial permutation. The most important fathoming test is the boundary test, which checks if the partial permutation can possibly lead to a complete permutation with a better solution than the currently best one. In this way large parts of the search space can be omitted. However, in contrast to the dynamic programming approach, the reduction of search space is strongly data dependent and poorly structured data can lead to very poor performance. With branch-and-bound slightly larger problems can be solved than with dynamic programming in reasonable time. \cite{seriation:Brusco:2005} state that depending on the data, in some cases proximity matrices with 40 or more objects can be handled with current hardware. Partial enumeration methods can be used to find the exact solution independently of the loss/merit function. However, partial enumeration is limited to only relatively small problems. \subsection{Traveling salesperson problem solver} Seriation by minimizing the length of a Hamiltonian path through a graph is equal to solving a traveling salesperson problem. The traveling salesperson or salesman problem (TSP) is a well known and well researched combinatorial optimization problem~\citep[see, e.g.,][]{seriation:Gutin:2002}. The goal is to find the shortest tour that, starting from a given city, visits each city in a given list exactly once and then returns to the starting city. In graph theory a TSP tour is called a \emph{Hamiltonian cycle.} But for the seriation problem, we are looking for a Hamiltonian path. \cite{seriation:Garfinkel:1985} described a simple transformation of the TSP to find the shortest Hamiltonian path. An additional row and column of 0's is added (sometimes this is referred to as a \emph{dummy city}) to the original $n \times n$ dissimilarity matrix~$\mathbf{D}$. The solution of this $(n+1)$-city TSP, gives the shortest path where the city representing the added row/column cuts the cycle into a linear path. As the general seriation problem, solving the TSP is difficult. In the seriation case with $n+1$ cities, $n!$ tours have to be checked. However, despite this vast searching space, small instances can be solved efficiently using dynamic programming \citep{seriation:Held:1962} and larger instances of several hundred objects can be solved using \emph{branch-and-cut} algorithms~\citep{seriation:Padberg:1990}. For even larger instances or if running time is critical, a wide array of heuristics are available, ranging from simple nearest neighbor approaches to construct a tour~\citep{seriation:Rosenkrantz:1977} to complex heuristics like the Lin-Kernighan heuristic~\citep{seriation:Lin:1973}. A comprehensive overview of heuristics and exact methods can be found in \cite{seriation:Gutin:2002}. \subsection{Bond energy algorithm} The \emph{bond energy algorithm}~\citep[BEA;][]{seriation:McCormick:1972} is a simple heuristic to rearrange columns and rows of a matrix (two-way two-mode data) such that each entry is as closely numerically related to its four neighbors as possible. To achieve this, BEA tries to maximize the measure of effectiveness (ME) defined in Section~\ref{sec:ME}. For optimizing the ME, columns and rows can be treated separately since changing the order of rows does not influence the ME contributions of the columns and vice versa. BEA consists of the following three steps: \begin{enumerate} \item Place one randomly chosen column. \item Try to place each remaining column at each possible position left, right and between the already placed columns and calculate every time the increase in ME. Choose the column and position which gives the largest increase in ME and place the column. Repeat till all columns are placed. \item Repeat procedure with rows. \end{enumerate} This greedy algorithm works fast and only depends on the choice of the first column/row. This dependence can be reduced by repeating the procedure several times with different choices and returning the solution with the highest ME. Although \cite{seriation:McCormick:1972} use BEA also for non-binary data, \cite{seriation:Arabie:1990} argue that the measure of effectiveness only serves its intended purpose of finding an arrangement which is close to Robinson form for binary data and should therefore only be used for binary data. \cite{seriation:Lenstra:1974} notes that the optimization problem of BEA can be stated as two independent traveling salesperson problems (TSPs). For example, the row TSP for an $n \times m$ matrix~$\mathbf{X}$ consists of $n$ cities with an $n \times n$ distance matrix~$\mathbf{D}$ where the distances are \begin{displaymath} d_{ij} = -\sum_{k=1}^m x_{ik}x_{jk}. \end{displaymath} BEA is in fact a simple suboptimal TSP heuristic using this distances and instead of BEA any TSP solver can be used to obtain an order. With an exact TSP solver, the optimal solution can be found. \subsection{Hierarchical clustering} \label{sec:hierarchical_clustering} Hierarchical clustering produces a series of nested clusterings which can be visualized by a dendrogram, a tree where each internal node represents a split into subtrees and has a measure of similarity/dissimilarity attached to it. As a simple heuristic to find a linear order of objects, the order of the leaf nodes in a dendrogram structure can be used. This idea is used, e.g., by heat maps to reorder rows and columns with the aim to place more similar objects and variables closer together. %For hierarchical clustering several methods are available (e.g., %single linkage, average linkage, complete linkage, ward method) resulting in %different dendrograms. %However, The order of leaf nodes in a dendrogram is not unique. A binary (two-way splits only) dendrogram for $n$ objects has $2^{n-1}$ internal nodes and at each internal node the left and right subtree (or leaves) can be swapped resulting in $2^{n-1}$ distinct leaf orderings. To find a unique or optimal order, an additional criterion has to be defined. \cite{seriation:Gruvaeus:1972} suggest to obtain a unique order by requiring to order the leaf nodes such that at each level the objects at the edge of each cluster are adjacent to that object outside the cluster to which it is nearest. \cite{seriation:Bar-Joseph:2001} suggest to rearrange the dendrogram such that the Hamiltonian path connecting the leaves is minimized and called this the optimal leaf order. The authors also present a fast algorithm with time complexity $O(n^4)$ to solve this optimization problem. Note that this problem is related to the TSP described above, however, the given dendrogram structure significantly reduces the number of permissible permutations making the problem easier. Although hierarchical clustering solves an optimization problem different to the seriation problem discussed in this paper, hierarchical clustering still can produce useful orderings, e.g., for visualization. \subsection{Rank-two ellipse seriation} \cite{seriation:Chen:2002} proposes to generate a sequence of correlation matrices $R^1, R^2, \ldots$. $R^1$ is the correlation matrix of the original distance matrix $\mathbf{D}$ and \begin{equation} R^{n+1} = \phi R^n, \end{equation} where $\phi(\cdot)$ calculates a correlation matrix. \cite{seriation:Chen:2002} shows that the rank of the matrix $R^n$ falls with increasing $n$ and that if the sequence is continued till the first matrix in the sequence has a rank of 2, projecting all points in this matrix on its first two eigenvectors, all points will fall on an ellipse. \cite{seriation:Chen:2002} suggests to use the order of the points on this ellipse as a seriation where the ellipse can be cut at any of the two interception points (top or bottom) with the vertical axis. Although the rank-two ellipse seriation procedure does not try to solve a combinatorial optimization problem, it still provides for some cases a useful ordering. \subsection{Spectral Seriation} Spectral seriation uses a relaxation to minimize the 2-Sum Problem \citep{seriation:Barnard:1993}. Rewriting the minimization problem using a permutation vector $\pi$, its inverse, rescaling to $\mathrm{q}$ and using a Lagrangian multiplier for the constraint on the permutation yields \citep{seriation:Ding:2004} the following equivalent optimization problem: $$\mathrm{min}_\mathbf{q} \frac{\mathbf{q}^T L_\mathbf{S}\mathbf{q}}{\mathbf{q}^T\mathbf{q}}$$ where $L_\mathbf{S}$ is the Laplacian of $\mathbf{S}$. The optimal order can be recovered by the sorting order of the Fiedler vector (i.e., the second smallest eigenvector of the Laplacian of the similarity matrix). \subsection{Quadratic Assignment Problem} Both, the linear seriation criterion and the 2-Sum problem formulation can be written as a Quadratic Assignment Problem (QAP). However, the QAP is in general NP-hard. Methods include QIP, linearization, branch and bound and cutting planes as well as heuristics including Tabu search, simulated annealing, genetic algorithms, and ant systems \citep{seriation:Burkard:1998}. \section{The package infrastructure} \label{sec:infrastructure} The \pkg{seriation} package provides the data structures and some algorithms to efficiently handle seriation with \proglang{R}. As the input data for seriation \proglang{R} already provides \begin{itemize} \item for two-way one-mode data the class \code{dist}, \item for two-way two-mode data the class \code{matrix}, and \item for $k$-way $k$-mode data the class \code{array}. \end{itemize} \begin{figure}[tp] \centerline{ %\includegraphics[width=12cm]{infrastructure}} \includegraphics[width=10cm]{classes}} \caption{UML class diagram of the data structures for permutations provided by \pkg{seriation}} \label{fig:infrastructure} \end{figure} However, \proglang{R} provides no classes for representing permutation vectors. \pkg{seriation} adds the necessary data structure (using the S3 class system) as depicted in the UML class diagram \citep{seriation:Fowler:2004} in Figure~\ref{fig:infrastructure}. In this diagram classes are represented by rectangles and different symbols are used to state the type of relationship between the classes. The class \code{ser\_permutation} in Figure~\ref{fig:infrastructure} represents the permutation information for $k$-mode data (including the cases of $k=1$ and $k=2$). It consists of $k$ permutation vectors (class \code{ser\_permutation\_vector}). This relationship is represented by the solid diamond and the star above the connection between the two classes. Class \code{ser\_permutation\_vector} is defined \emph{abstract} and only its concrete implementations (classes connected with the triangle symbol) are used to store a permutation vector. This design with an abstract class was chosen to allow to use different representations for the permutation vectors. Currently, the permutation vector can be stored as a simple integer vector or as an object of class \code{hclust} (defined in package \pkg{stats}). \code{hclust} describes a hierarchical clustering tree (dendrogram) including an ordering for the tree's node leaves which provides a permutation for all objects (see Section~\ref{sec:hierarchical_clustering}). Class \code{ser\_permutation\_vector} has a constructor \func{ser\_permutation\_vector} which converts data into the correct concrete subclass of \code{ser\_permutation\_vector} and checks if it contains a proper permutation vector. For \code{ser\_permutation\_vector} the methods \func{print}, \func{length} for the length of the permutation vector, \func{get\_method} to get the method used to generate the permutation, and \func{get\_order} to access the raw (integer) permutation vector are available. To use an additional class to represent permutations as a concrete subclass of \code{ser\_permutation\_vector} only an appropriate accessor method \func{get\_order} has to be implemented for the new class. For \code{ser\_permutation} a constructor is provided which can bind $k$ \code{ser\_permutation\_vector} objects together into an object for $k$-mode data. \code{ser\_permutation} is implemented as a list of length~$k$ and each element contains a \code{ser\_permutation\_vector} object. Methods like \func{length}, accessing elements with \code{[[}, % ]] \code{[[<-}, % ]] subsetting with \code{[}, and combining with \func{c} work as expected. Also a \func{print} method is provided. Finally, direct access to the raw permutation vectors is available using \func{get\_order}. Here a second argument (which defaults to $1$) specifies the dimension (mode) for which the order vector is requested. All seriation algorithms are available via the function \func{seriate} defined as: \begin{quotation} \code{seriate(x, method = NULL, control = NULL, ...)} \end{quotation} where \code{x} is the input data, \code{method} is a string defining the seriation method to be used and \code{control} can contain a list with additional information for the algorithm. \func{seriate} returns an object of class \code{ser\_permutation} with a length conforming to the number of dimensions of~\code{x}. Typical input data are a dissimilarity matrix (class~\code{dist}; see package \pkg{stats} for more information) for one-mode two-way data, \code{matrix} for two-mode two-way data and \code{array} for $k$-mode $k$-way data. For \code{matrix} and \code{array} the additional argument \code{margin} can be used to restrict the dimensions which should be seriated (e.g., with \code{margin = 1} only the first dimension, i.e., the columns of a matrix, are seriated). %\begin{landscape} \begin{table}[tp] \centering \begin{tabular}{p{5cm}p{3cm}p{4cm}l} \hline Algorithm & \code{method} & Optimizes & Input data \\ \hline Simulated annealing & \code{"ARSA"} & Linear seriation crit.&\code{dist} \\ Branch-and-bound & \code{"BBURCG"} & Gradient measure &\code{dist} \\ Branch-and-bound & \code{"BBWRCG"} & Gradient measure (weighted)& \code{dist} \\ TSP solver & \code{"TSP"} & Hamiltonian path length& \code{dist} \\ Optimal leaf ordering & \code{"OLO"} \code{"OLO_single"} \code{"OLO_average"} \code{"OLO_complete"} & Hamiltonian path length (restricted)& \code{dist} \\ Gruvaeus and Wainer & \code{"GW"} \code{"GW_single"} \code{"GW_average"} \code{"GW_complete"} & Hamiltonian path length (restricted) & \code{dist} \\ MDS & \code{"MDS"} \code{"MDS_metric"} \code{"MDS_nonmetric"} \code{"MDS_angle"} & Least square crit.& \code{dist} \\ Spectral seriation & \code{"Spectral"} \code{"Spectral_norm"} & 2-Sum crit. & \code{dist} \\ QAP & \code{"QAP_2SUM"} & 2-Sum crit. & \code{dist} \\ & \code{"QAP_LS"} & Linear seriation crit. & \code{dist} \\ & \code{"QAP_BAR"} & Banded AR form & \code{dist} \\ & \code{"QAP_Inertia"} & Inertia crit. & \code{dist} \\ Genetic Algorithm & \code{"GA"}* & various & \code{dist} \\ DendSer & \code{"DendSer"}* & various & \code{dist} \\ Hierarchical clustering & \code{"HC"} \code{"HC_single"} \code{"HC_average"} \code{"HC_complete"} & Other& \code{dist} \\ Rank-two ellipse seriation & \code{"R2E"} & Other& \code{dist} \\ Sorting Points Into Neighborhoods & \code{"SPIN_NH"} \code{"SPIN_STS"} & Other& \code{dist} \\ Visual Assessment of (Clustering) Tendency & \code{"VAT"}& Other& \code{dist} \\ \hline Bond Energy Algorithm & \code{"BEA"} & Measure of effectiveness & \code{matrix} \\ TSP to optimize ME & \code{"BEA\_TSP"} & Measure of effectiveness& \code{matrix} \\ Principal component analysis& \code{"PCA"} \code{"PCA_angle"}& Least square crit.& \code{matrix} \\ \hline \end{tabular} \caption{Currently implemented methods for \func{seriation} (* methods need to be registered).} \label{tab:methods} \end{table} %\end{landscape} Various seriation methods were already introduced in this paper in Section~\ref{sec:methods}. In Table~\ref{tab:methods} we summarize the methods currently available in the package for seriation. The code for the simulated annealing heuristic~\citep{seriation:Brusco:2007} and the two branch-and-bound implementations~\citep{seriation:Brusco:2005} was obtained from the authors. The TSP solvers (exact solvers and a variety of heuristics) is provided by package \pkg{TSP}~\citep{seriation:Hahsler:2007, seriation:Hahsler:2007b}. For optimal leaf ordering we implemented the algorithm by~\cite{seriation:Bar-Joseph:2001}. The BEA code was kindly provided by Fionn Murtagh. For the Gruvaeus and Wainer algorithm, the implementation in package \pkg{gclus}~\citep{seriation:Hurley:2007} is used. For the rank-two ellipse seriation we implemented the algorithm by~\cite{seriation:Chen:2002}. Spectral seriation is described by~\cite{seriation:Ding:2004}. Note that some methods implemented (e.g., the rank-two ellipse seriation) do not fall within the combinatorial optimization framework of this paper and thus are not dealt with here in detail. They are included in the package since they can be useful for various applications. A detailed empirical comparison of seriation methods and criteria can be found in the study by \cite{hahsler:Hahsler2016d}. %Over time more methods will be %added to the package. To calculate the value of a loss/merit function for data and a certain permutation, the function \begin{quotation} \code{criterion(x, order = NULL, method = NULL, ...)} \end{quotation} is provided. \code{x} is the data object, \code{order} contains a suitable object of class \code{ser\_permutation} (if omitted no permutation is performed) and \code{method} specifies the type of loss/merit function. A vector of several methods can be used resulting in a named vector with the values of the requested functions. If \code{method} is omitted (\code{method = NULL}), the values for all applicable loss/merit functions are calculated and returned. We already defined different loss/merit functions for seriation in Section~\ref{sec:seriation}. In Table~\ref{tab:criteria} we indicate the loss/merit functions currently available in the package. \begin{table}[t] \centering \begin{tabular}{llll} \hline Name & \code{method} & merit/loss & Input data \\ \hline Anti-Robinson events& \code{"AR\_events"} & loss & \code{dist} \\ Anti-Robinson deviations& \code{"AR\_deviations"} & loss & \code{dist} \\ Banded Anti-Robinson& \code{"BAR"} & loss & \code{dist} \\ Gradient measure& \code{"Gradient\_raw"} & merit & \code{dist} \\ Gradient measure (weighted)& \code{"Gradient\_weighted"} & merit & \code{dist} \\ Hamiltonian path length & \code{"Path\_length"} & loss & \code{dist} \\ Inertia criterion& \code{"Inertia"} & merit & \code{dist} \\ Least squares criterion& \code{"Least\_squares"} & loss & \code{dist} \\ Linear Seriation criterion& \code{"LS"} & loss & \code{dist} \\ 2-Sum criterion& \code{"2SUM"} & loss & \code{dist} \\ \hline Measure of effectiveness& \code{"ME"} & merit & \code{matrix} \\ Stress (Moore neighborhood)& \code{"Moore\_stress"} & loss & \code{matrix} \\ Stress (Neumann neighborhood)& \code{"Neumann\_stress"} & loss & \code{matrix} \\ \hline \end{tabular} \caption{Implemented loss/merit functions in function \func{criterion}.} \label{tab:criteria} \end{table} All methods for \func{seriate} and \func{criterion} are managed by a registry mechanism which makes the seriation framework easily extensible for users. For example, a new seriation method can be registered using \func{set\_seriation\_method} and then used in the same way as the built-in methods with \func{seriate}. All available methods in the registry can be viewed using \func{list\_seriation\_methods} and \func{show\_seriation\_methods}. For criterion methods, the same interface is available by just substituting `seriation' by `criterion' in the function names. An example for how to add new methods can be found in section~\ref{sec:registering} of this paper. In addition the package offers the (generic) function \begin{quotation} \code{permute(x, order)} \end{quotation} where \code{x} is the data (a \code{dist} object, a matrix, an array, a list or a numeric vector) to be reordered and \code{order} is a \code{ser\_permutation} object of suitable length. %The permutation for %\code{dist} objects uses package \pkg{proxy}~\citep{seriation:Meyer:2007}. For visualization, the package offers several options: \begin{itemize} \item Matrix shading with \func{pimage}. In contrast to the standard \func{image} in package~\pkg{graphics}, \func{pimage} displays the matrix as is with the first element in the top left-hand corner and using a gamma-corrected gray scale. \item Different heat maps (e.g., with optimally reordered dendrograms) with \func{hmap}. \item Visualization of data matrices in the spirit of~\cite{seriation:Bertin:1981} with \func{bertinplot}. \item \emph{Dissimilarity plot}, a new visualization to judge the quality of a clustering using matrix shading and seriation with \func{dissplot}. \end{itemize} We will introduce the package usage and the visualization options in the examples in the next section. \section{Examples and applications} \label{sec:example} We start this section with a simple first session to demonstrate the basic usage of the package. Then we present and discuss several seriation applications. \subsection{A first session using seriation} In the following example, we use the well known iris data set (from \proglang{R}'s \pkg{datasets} package) which gives the measurements in centimeters of the variables sepal length and width and petal length and width, respectively, for 50 flowers from each of 3 species of the iris family (Iris setosa, versicolor and virginica). First, we load the package \pkg{seriation} and the iris data set. We remove the species classification and reorder the objects randomly since they are already sorted by species in the data set. Then we calculate the Euclidean distances between objects. <>= set.seed(1234) @ <<>>= library("seriation") data("iris") x <- as.matrix(iris[-5]) x <- x[sample(seq_len(nrow(x))),] d <- dist(x) @ To seriate the objects given the dissimilarities, we just call \func{seriate} with the default settings. <<>>= o <- seriate(d) o @ The result is an object of class \code{ser\_permutation} for one-mode data. The permutation vector length is $150$ for the $150$ objects in the iris data set and the used seriation method is \code{"ARSA"}, a simulated annealing heuristic (see~Table~\ref{tab:methods}). The actual order can be accessed using \func{get\_order}. In the following we show the first 15 elements in the permutation vector. <<>>= head(get_order(o), 15) @ To visually inspect the effect of seriation on the distance matrix, we use matrix shading with \func{pimage} (the result is shown in Figure~\ref{fig:pimage1}). <>= pimage(d, main = "Random") @ <>= pimage(d, o, main = "Reordered") @ \begin{figure} \centering \includegraphics[width=7.5cm]{seriation-pimage1} \includegraphics[width=7.5cm]{seriation-pimage1-2} \caption{Matrix shading of the distance matrix for the iris data.} \label{fig:pimage1} \end{figure} We can also compare the improvement for different loss/merit functions using \func{criterion}. <<>>= cbind(random = criterion(d), reordered = criterion(d, o)) @ Naturally, the reordered dissimilarity matrix achieves better values for all criteria. Note that the gradient measures, inertia and the measure of effectiveness are merit functions and for these measures larger values are better (use \code{show\_criterion\_methods("dist")} to find out which measures are loss and merit functions). To visually compare the original data matrix and the result of seriation, we can also use \func{pimage}. We standardize the data using scale such that the visualized value is the number of standard deviations an object differs from the variable mean. For matrices containing negative values, \code{pimage} uses automatically a divergent palette. After using \func{pimage} for the original random data matrix, we create a suitable \code{ser\_permutation} object for the original two-mode data. Since the seriation above only produced an order for the rows of the data, we add an identity permutation vector for the columns (represented by \code{NA}) to the permutations object using the combine function \func{c}. This new permutation object for $2$-mode data is used for displaying the reordered scaled data. The two plots are shown in Figure~\ref{fig:pimage2}. <>= pimage(scale(x), main = "Random", prop = FALSE) @ <>= o_2mode <- c(o, NA) pimage(scale(x), o_2mode, main = "Reordered", prop = FALSE) @ \begin{figure} \centering \includegraphics[width=7.5cm]{seriation-pimage2} \includegraphics[width=7.5cm]{seriation-pimage2-2} \caption{Matrix shading of the iris data matrix.} \label{fig:pimage2} \end{figure} \subsection{Comparing different seriation methods} To compare different seriation methods we use again the randomized iris data set and the distance matrix \code{d} from the previous example. We include in the comparison several seriation methods for dissimilarity matrices described in Section~\ref{sec:methods}. <<>>= methods <- c("TSP","R2E", "ARSA", "HC", "GW", "OLO") o <- sapply(methods, FUN = function(m) seriate(d, m)) @ <>= timing <- sapply(methods, FUN = function(m) system.time(seriate(d, m)), simplify = FALSE) @ \begin{table} \centering \begin{tabular}{lcccccc} \hline Seriation Method & \Sexpr{methods[1]}& \Sexpr{methods[2]}& \Sexpr{methods[3]}& \Sexpr{methods[4]}& \Sexpr{methods[5]}& \Sexpr{methods[6]} \\ \hline Execution time [sec] & \Sexpr{round(timing[[methods[1]]][1],4)}& \Sexpr{round(timing[[methods[2]]][1],4)}& \Sexpr{round(timing[[methods[3]]][1],4)}& \Sexpr{round(timing[[methods[4]]][1],4)}& \Sexpr{round(timing[[methods[5]]][1],4)}& \Sexpr{round(timing[[methods[6]]][1],4)}\\ \hline \end{tabular} %%% fix me: for the vignette we need something else \caption{Execution time of seriation of the iris data set for different methods.} \label{tab:timings} \end{table} Table~\ref{tab:timings} contains the execution times for running seriation with the different methods. Except for the simulated annealing method (ARSA) the seriation only takes a fraction of a second. The direction of the resulting orderings is first normalized (aligned) and then the orderings are displayed using matrix shading (see Figure~\ref{fig:pimage3}). <>= o <- ser_align(o) for(s in o) pimage(d, s, main = get_method(s), key = FALSE) @ <>= o <- ser_align(o) for(i in 1:length(o)) { pdf(file=paste("seriation-pimage_comp_", i , ".pdf", sep="")) pimage(d, o[[i]], main = get_method(o[[i]]), key = FALSE) dev.off() } @ \begin{figure} \centering \includegraphics[width=.3\linewidth]{seriation-pimage_comp_1.pdf} \includegraphics[width=.3\linewidth]{seriation-pimage_comp_2.pdf} \includegraphics[width=.3\linewidth]{seriation-pimage_comp_3.pdf}\\ \includegraphics[width=.3\linewidth]{seriation-pimage_comp_4.pdf} \includegraphics[width=.3\linewidth]{seriation-pimage_comp_5.pdf} \includegraphics[width=.3\linewidth]{seriation-pimage_comp_6.pdf} \caption{Image plot of the distance matrix for the iris data using rearrangement by different seriation methods.} \label{fig:pimage3} \end{figure} The first row of matrices in Figure~\ref{fig:pimage3} contains the orders obtained by a TSP solver the rank-two ellipse seriation by Chen and using the simulated annealing method (ARSA). The results of Chen and ARSA are very similar (except that the order is reversed). The TSP solver produces a smoother image with some lighter lines visible. The reason for these lines is that the TSP only optimizes distances locally between two neighboring objects. Therefore it is possible that in a quite homogeneous block several objects are enclosed gradually getting more different and then getting more similar again (see, e.g., the light line close to the upper left corner of the TSP image in Figure~\ref{fig:pimage3}). The second row of Figure~\ref{fig:pimage3} contains three images based on hierarchical clustering. The visual impression gets better from left (just hierarchical clustering) to right (first using the Gruvaeus Wainer heuristic and then optimal leaf ordering to rearrange the branches of the dendrogram obtained by hierarchical clustering). The most striking feature in the image for hierarchical clustering (HC in Figure~\ref{fig:pimage3}) is the distinct cross going right through the center of the plot. This indicates that several relatively dissimilar objects are caught in an otherwise homogeneous block. This effect vanishes after rearranging the dendrogram branches (see GW and OLO in Figure~\ref{fig:pimage3}). %' To investigate this effect, %' we plot the dendrogram obtained by hierarchical clustering which is used %' to order the objects and compare it to the dendrogram rearranged %' using the Gruvaeus Wainer heuristic. %' %' <>= %' plot(o[["HC"]], labels = FALSE, main = "Dendrogram HC") %' plot(o[["GW"]], labels = FALSE, main = "Dendrogram GW") %' @ %' <>= %' def.par <- par(no.readonly = TRUE) %' pdf(file="seriation-pimage3_dendrogram.pdf", width=9, height=4) %' layout(t(1:2)) %' plot(o[["HC"]], labels = FALSE, main = "Dendrogram HC") %' symbols(74.7,.5, rect = matrix(c(4, 3), ncol=2), add= TRUE, %' inches = FALSE, lwd =2) %' %' plot(o[["GW"]], labels = FALSE, main = "Dendrogram GW") %' symbols(98.7,.5, rect = matrix(c(4, 3), ncol=2), add= TRUE, %' inches = FALSE, lwd =2) %' par(def.par) %' tmp <- dev.off() %' @ %' %' \begin{figure} %' \centering %' \includegraphics[width=\linewidth, trim=0 80 0 0, clip=TRUE]{seriation-pimage3_dendrogram} %' \caption{Dendrograms for the seriation with HC and GW.} %' \label{fig:pimage3_dendrogram} %' \end{figure} %' %' Comparing the two dendrograms in Figure~\ref{fig:pimage3_dendrogram}, we see %' that the branch left from the top is almost unchanged. The branch which is %' responsible for the light cross in the shaded image is highlighted by a box. %' The Gruvaeus Wainer heuristic rotates the highlighted branch towards the right %' since the objects in it are more similar to the objects in there. Finally, we compare the values of the loss/merit functions for the different seriation methods. <<>>= crit <- sapply(o, FUN = function(x) criterion(d, x)) t(crit) @ <>= def.par <- par(no.readonly = TRUE) m <- c("Path_length", "AR_events", "Moore_stress") layout(matrix(seq_along(m), ncol=1)) #tmp <- apply(crit[m,], 1, dotchart, sub = m) tmp <- lapply(m, FUN = function(i) dotchart(crit[i,], sub = i)) par(def.par) @ \begin{figure} \centering \includegraphics[width=14cm]{seriation-crit1} \caption{Comparison of different methods and seriation criteria} \label{fig:crit1} \end{figure} For easier comparison, Figure~\ref{fig:crit1} contains a plot of the criteria Hamiltonian path length, anti-Robinson events (\code{AR\_events}) and stress using the Moore neighborhood. Clearly, the methods which directly try to minimize the Hamiltonian path length (hierarchical clustering with optimal leaf ordering (\code{OLO}) and the TSP heuristic) provide the best results concerning the path length. For the number of anti-Robinson events, using the simulated annealing heuristic (\code{ARSA}) provides the best result. Regarding stress, the simulated annealing heuristic also provides the best result although, it does not directly minimize this loss function. \subsection{Registering new methods} \label{sec:registering} New methods to calculate criterion values and to compute a seriation can be easily added by the user via the method registry mechanism provided in \pkg{seriation}. Here we give a simple example of how to implement and register a new seriation method. In the registry we distinguish between methods for different types of input data. With the following two commands we produce a list of the available seriation methods for input data of class \code{dist} and \code{matrix}. <<>>= list_seriation_methods("dist") list_seriation_methods("matrix") @ To get detailed information on a seriation method use the following. <<>>= get_seriation_method("dist", name = "ARSA") @ To add a new seriation method, we first have to implement the seriation code as a function with the two formal arguments \code{x} and \code{control}, and for arrays also an additional argument \code{margin}. \code{x} is the data object and \code{control} contains a list with additional information for the method passed on from \func{seriate}. The function has to return a list of objects which can be coerced into \code{ser\_permutation\_vector} objects (e.g., a list of integer vectors). The elements in the list have to be in order corresponding to the dimensions of \code{x}. In this example we just create a method to return a permutation which reverses the original order of the objects, i.e., which returns the reverse identity order. <<>>= seriation_method_reverse <- function(x, control = NULL, margin = seq_along(dim(x))) { lapply(seq_along(dim(x)), function(i) if (i %in% margin) rev(seq(dim(x)[i])) else NA) } @ The function produces integer sequences of the correct lengths, one for each dimension of \code{x} (\code{control} is not used). Since the function works for \code{matrix} and \code{array} we can register it for both data types under the short name `Reverse'. <<>>= set_seriation_method("matrix", "New_Reverse", seriation_method_reverse, "Reverse identity order") set_seriation_method("array", "New_Reverse", seriation_method_reverse, "Reverse identity order") @ Now the new seriation method is registered and can be found by the user and applied to data. <<>>= list_seriation_methods("matrix") o <- seriate(matrix(1, ncol = 3, nrow = 4), "New_Reverse") o get_order(o, 1) get_order(o, 2) @ Criterion methods can be added in the same way. We refer the interested reader to the documentation accompanying the package for detailed information and an example. If you have implemented a new criterion or seriation method, please consider submitting the code to one of the maintainers of \pkg{seriation} for inclusion in a future release of the package. \subsection{Heat maps} A heat map is a shaded/color coded data matrix with a dendrogram added to one side and to the top to indicate the order of rows and columns. Typically, reordering is done according to row or column means within the restrictions imposed by the dendrogram. Heat maps recently became popular for visualizing large scale genome expression data obtained via DNA microarray technology \citep[see, e.g.,][]{seriation:Eisen:1998}. From Section~\ref{sec:hierarchical_clustering} we know that it is possible to find the optimal ordering of the leaf nodes of a dendrogram which minimizes the distances between adjacent objects in reasonable time. Such an order might provide an improvement over using simple reordering such as the row or column means with respect to presentation. In \pkg{seriation} we provide the function \func{hmap} which uses optimal ordering and can also use seriation directly on distance matrices without using hierarchical clustering to produce dendrograms first. For the following example, we use again the randomly reordered iris data set \code{x} from the examples above. To make the variables (columns) comparable, we use standard scaling. <<>>= x <- scale(x, center = FALSE) @ To produce a heat map with optimally reordered dendrograms (using by default Optimal Leaf Ordering), the function \func{hmap} can be used with its default settings. <>= hmap(x, margin = c(7, 4), cexCol = 1, row_labels = FALSE) @ With these settings, the Euclidean distances between rows and between columns are calculated (with \func{dist}), hierarchical clustering (\func{hclust}) is performed, the resulting dendrograms are optimally reordered, and \func{heatmap.2} in package \pkg{gplots} is used for plotting (see Figure~\ref{fig:heatmap}(a) for the resulting plot). <>= hmap(x, method = "MDS") @ If a seriation method is used that does not depend on dendrograms, instead of hierarchical clustering, seriation on the dissimilarity matrices for rows and columns is performed and the reordered matrix with the reordered dissimilarity matrices to the left and on top is displayed (see Figure~\ref{fig:heatmap}(b)). A \code{method} argument can be used to choose different seriation methods. <>= #bitmap(file = "seriation-heatmap1.png", type = "pnggray", # height = 6, width = 6, res = 300, pointsize=14) pdf(file = "seriation-heatmap1.pdf") hmap(x, margin = c(7, 4), row_labels = FALSE, cexCol = 1) tmp <- dev.off() @ <>= pdf(file = "seriation-heatmap2.pdf") hmap(x, method="MDS") tmp <- dev.off() @ \begin{figure} \begin{minipage}[b]{.48\linewidth} \centering \includegraphics[width=\linewidth]{seriation-heatmap1} \\ (a) \end{minipage} \begin{minipage}[b]{.48\linewidth} \centering \includegraphics[width=\linewidth]{seriation-heatmap2} \\ (b) \end{minipage} \caption{Two presentations of the rearranged iris data matrix. (a) as an optimally reordered heat map and (b) as a seriated data matrix with reordered dissimilarity matrices to the left and on top.} \label{fig:heatmap} \end{figure} \subsection{Bertin's permutation matrix} \cite{seriation:Bertin:1981,seriation:Bertin:1999} introduced permutation matrices to analyze multivariate data with medium to low sample size. The idea is to reveal a more homogeneous structure in a data matrix~$\mathbf{X}$ by simultaneously rearranging rows and columns. The rearranged matrix is displayed and cases and variables can be grouped manually to gain a better understanding of the data. %To quantify homogeneity, a purity function %\begin{displaymath} % \phi = \Phi(\mathbf{X}) %\end{displaymath} %is defined. Let $\Pi$ be the set of all permutation functions %$\pi$ for matrix $\mathbf{X}$. %Note that function $\pi$ performs row and column permutations on a matrix. %The optimal permutation with respect to %purity can be found by %\begin{displaymath} % \pi^* = \argmax\nolimits_{\pi \in \Pi} \Phi(\pi(\mathbf{X})). %\end{displaymath} %Since, depending on the purity function, finding the optimal %solution can be hard, often a near optimal solution is also acceptable %for visualization. % %A possible purity function $\Phi$ is: %Given distances between rows and columns of the data matrix, define purity as %the sum of distances of adjacent rows/columns. Using this purity function, %finding the optimal permutation $\pi^*$ means solving two (independent) TSPs, %one for the columns and one for the rows. To find a rearrangement of columns and rows which reveals structure a purity function is used. A possible purity function is: Given distances between rows and columns of the data matrix, define purity as the sum of distances of adjacent rows/columns. Using this purity function, finding the optimal permutation means solving two (independent) TSPs, one for the columns and one for the rows which can be done very conveniently using the infrastructure provided by \pkg{seriation}. As an example, we use the results of $8$ constitutional referenda for $41$ Irish communities~\citep{seriation:Falguerolles:1997}\footnote{The Irish data set is included in this package. The original data and the text of the referenda can be obtained from~\url{http://www.electionsireland.org/}}. To make values comparable across columns (variables), the ranks of the values for each variable are used instead of the original values. <<>>= data("Irish") orig_matrix <- apply(Irish[,-6], 2, rank) @ For seriation, we calculate distances between rows and between columns using the sum of absolute rank differences (this is equal to the Minkowski distance with power $1$). Then we apply seriation (using a TSP heuristic) to both distance matrices and combine the two resulting \code{ser\_permutation} objects into one object for two-mode data. The original and the reordered matrix are plotted using \func{bertinplot}. <<>>= o <- c( seriate(dist(orig_matrix, "minkowski", p = 1), method = "TSP"), seriate(dist(t(orig_matrix), "minkowski", p = 1), method = "TSP") ) o @ In a newer version of the package this can be also done with the new heatmap seriation method for matrices. <<>>= get_seriation_method("matrix", name = "heatmap") o <- seriate(orig_matrix, method = "heatmap", dist_fun = function(d) dist(d, "minkowski", p = 1), seriation_method = "TSP") o @ <>= bertinplot(orig_matrix) bertinplot(orig_matrix, o) @ <>= bertinplot(orig_matrix) @ <>= bertinplot(orig_matrix, o) @ \begin{figure} \centering \includegraphics[width=15cm, trim=60 60 0 0]{seriation-bertin1} \\ (a) \includegraphics[width=15cm, trim=60 60 0 0]{seriation-bertin2} \\ (b) \caption{Bertin plot for the (a) original arrangement and the (b) reordered Irish data set.} \label{fig:bertin} \end{figure} The original matrix and the rearranged matrix are shown in Figure~\ref{fig:bertin} as a matrix of bars where high values are highlighted (filled blocks). Note that following Bertin, the cases (communities) are displayed as the columns and the variables (referenda) as rows. Depending on the number of cases and variables, columns and rows can be exchanged to obtain a better visualization. Although the columns are already ordered (communities in the same city appear consecutively) in the original data matrix in Figure~\ref{fig:bertin}(a), it takes some effort to find structure in the data. For example, it seems that the variables `Marriage', `Divorce', `Right to Travel' and `Right to Information' are correlated since the values are all high in the block made up by the columns of the communities in Dublin. The reordered matrix confirms this but makes the structure much more apparent. Especially the contribution of low values (which are not highlighted) to the overall structure becomes only visible after rearrangement. \subsection{Binary data matrices} Binary or $0$-$1$ data matrices are quite common. Often such matrices are called \emph{incidence matrices} since a $1$ in a cell indicates the incidence of an event. In archeology such an event could be that a special type of artifact was found at a certain archaeological site. This can be seen as a simplification of a so-called \emph{abundance matrix} which codes in each cell the (relative) frequency or quantity of an artifact type at a site. See \cite{seriation:Ihm:2005} for a comparison of incidence and abundance matrices in archeology. Here we are interested in binary data. For the example we use an artificial data set from~\cite{seriation:Bertin:1981} called \emph{Townships}. The data set contains $9$ binary characteristics (e.g., has a veterinary or has a high school) for $16$ townships. The idea of the data set is that townships evolve from a rural to an urban environment over time. After loading the data set (which comes with the package), we use \func{bertinplot} to visualize the data (\func{pimage} could also be used but \func{bertinplot} allows for a nicer visualization). Bars, the standard visualization of \func{bertinplot}, do not make much sense for binary data. We therefore use the panel function \func{panel.squares} without spacing to plot black squares. <>= data("Townships") bertinplot(Townships, panel = panel.tiles) @ The original data in Figure~\ref{fig:binary}(a) does not reveal structure in the data. To improve the display, we run the bond energy algorithm (BEA) for columns and rows $10$ times with random starting points and report the best solution. <>= ## to get consistent results set.seed(10) @ <>= o <- seriate_rep(Townships, method = "BEA", criterion = "ME", rep = 10) bertinplot(Townships, o, panel = panel.tiles) @ The reordered matrix is displayed in Figure~\ref{fig:binary}(b). A clear structure is visible. The variables (rows in a Bertin plot) can be split into the three categories describing different evolution states of townships: \begin{enumerate} \item Rural: No doctor, one-room school and possibly also no water supply \item Intermediate: Land reallocation, veterinary and agricultural cooperative \item Urban: Railway station, high school and police station \end{enumerate} The townships also clearly fall into these three groups which tentatively can be called villages (first~$7$), towns (next~5) and cities (final~2). The townships B and C are on the transition to the next higher group. \begin{figure} \centering \includegraphics[width=12cm, trim=0 40 0 30]{seriation-binary1} \\ (a) \includegraphics[width=12cm, trim=0 40 0 30]{seriation-binary2} \\ (b) \caption{The townships data set in original order (a) and reordered using BEA (b).} \label{fig:binary} \end{figure} <<>>= rbind( original = criterion(Townships), reordered = criterion(Townships, o) ) @ BEA tries to maximize the measure of effectiveness which is much higher in the reordered matrix (in fact, 65 is the maximum for the data set). Also the two types of stress are improved significantly. \subsection{Dissimilarity plot} Assessing the quality of an obtained cluster solution has been a research topic since the invention of cluster analysis. This is especially important since all popular cluster algorithms produce a clustering even for data without a ``cluster'' structure. %A method to judge the quality of a cluster solution is by inspecting a %visualization. For hierarchical clustering %dendrogramms~\cite{seriation:Hartigan:1967} are available which show the %hierarchical structure of the clustering as a binary tree and cluster quality %can be judged by looking at the dissimilarities between objects in a cluster %and objects in other clusters. However, such a visualization is %only possible for heirarchical/nested clusterings. % %\marginpar{Cite Pison et al 1999 and Kaufmann and Rousseeuw} %For the an arbitrary partitional clustering, the original objects can %be displayed in a 2 dimensional scatter plot %after using dimensionality reduction (e.g., PCA, MDS). %Objects belonging to the same cluster can be marked and thus, if the %dimensionality reduction preserves a large proportion of the %variavility in the original data, the separation between clusters can be %visually judged. % %Silhouettes Matrix shading is an old technique to visualize clusterings by displaying the rearranged matrices~\citep[see, e.g.,][]{seriation:Sneath:1973,seriation:Ling:1973,seriation:Gale:1984}. Initially matrix shading was used in connection with hierarchical clustering, where the order of the dendrogram leaf nodes was used to arrange the matrix. However, with some extensions, matrix shading can also be used with any partitional clustering method. \cite{seriation:Strehl:2003} suggest a matrix shading visualization called \emph{CLUSION} where the dissimilarity matrix is arranged such that all objects pertaining to a single cluster appear in consecutive order in the matrix. The authors call this \emph{coarse seriation}. The result of a ``good'' clustering should be a matrix with low dissimilarity values forming blocks around the main diagonal. However, using coarse seriation, the order of the clusters has to be predefined and the objects within each cluster are unordered. The dissimilarity plots implemented by the function \func{dissplot} in \pkg{seriation} improve \emph{CLUSION} using seriation methods. It aims at visualizing global structure (similarity between different clusters is reflected by their position relative to each other) as well as the micro structure within each cluster (position of objects). To position the clusters in the dissimilarity plot, an inter-cluster dissimilarity matrix is calculated using the average between cluster dissimilarities. \func{seriate} is used on this inter-cluster dissimilarity matrix to arrange the clusters relative to each other resulting in on average more similar clusters to appear closer together in the plot. Within each cluster, \func{seriate} is used again on the sub-matrix of the dissimilarity matrix concerning only the objects in the cluster. For the example, we use again Euclidean distance between the objects in the iris data set. <<>>= data("iris") iris <- iris[sample(seq_len(nrow(iris))), ] x_iris <- iris[, -5] d_iris <- dist(x_iris, method = "euclidean") @ First, we use \func{dissplot} without a clustering. We set \code{method} to \code{NA} to prevent reordering and display the original matrix (see Figure~\ref{fig:dissplot1}(a)). Then we omit the method argument which results in using the default seriation technique from \func{seriate}. Since we did not provide a clustering, the whole matrix is reordered in one piece. From the result shown in Figure~\ref{fig:dissplot1}(b) it seems that there is a clear structure in the data which suggests a two cluster solution. <>= ## plot original matrix dissplot(d_iris, method = NA) @ <>= ## plot reordered matrix dissplot(d_iris, main = "Dissimilarity plot with seriation") @ <>= pdf(file = "seriation-dissplot1.pdf") <> tmp <- dev.off() pdf(file = "seriation-dissplot2.pdf") <> tmp <- dev.off() @ \begin{figure} \begin{minipage}[b]{.48\linewidth} \centering \includegraphics[width=\linewidth]{seriation-dissplot1} \\ (a) \end{minipage} \begin{minipage}[b]{.48\linewidth} \centering \includegraphics[width=\linewidth]{seriation-dissplot2} \\ (b) \end{minipage} \caption{Two dissimilarity plots. (a) the original dissimilarity matrix and (b) the seriated dissimilarity matrix.} \label{fig:dissplot1} \end{figure} Next, we create a cluster solution using the $k$-means algorithm. Although we know that the data set should contain $3$ groups representing the three species of iris, we let $k$-means produce a $10$ cluster solution to study how such a misspecification can be spotted using \func{dissplot}. <>= set.seed(1234) @ <<>>= l <- kmeans(x_iris, 10)$cluster #$ @ We create a standard dissimilarity plot by providing the cluster solution as a vector of labels. The function rearranges the matrix and plots the result. Since rearrangement can be a time consuming procedure for large matrices, the rearranged matrix and all information needed for plotting is returned as the result. <>= res <- dissplot(d_iris, labels = l, main = "Dissimilarity plot - standard") @ <>= pdf(file = "seriation-dissplot3.pdf") ## visualize the clustering <> tmp <- dev.off() pdf(file = "seriation-dissplot4.pdf") ## threshold plot(res, main = "Dissimilarity plot - threshold", threshold = 3) tmp <- dev.off() @ \begin{figure} \centering \includegraphics[width=10cm]{seriation-dissplot3}\\ (a) \includegraphics[width=10cm]{seriation-dissplot4}\\ (b) \caption{Dissimilarity plot for $k$-means solution with 10 clusters. (a) standard plot and (b) plot with threshold.} \label{fig:dissplot3} \end{figure} <<>>= res @ The resulting plot is shown in Figure~\ref{fig:dissplot3}(a). The inter-cluster dissimilarities are shown as solid gray blocks and the average object dissimilarity within each cluster as gray triangles below the main diagonal of the matrix. Since the clusters are arranged such that more similar clusters are closer together, it is easy to see in Figure~\ref{fig:dissplot3}(a) that clusters 6, 3 and 1 as well as clusters 10, 9, 5, 7, 8, 4 and 2 are very similar and form two blocks. This suggests again that a two cluster solution would be reasonable. Since slight variations of gray values are hard to distinguish, we plot the matrix again (using \func{plot} on the result above) and use a threshold on the dissimilarity to suppress high dissimilarity values in the plot. <>= plot(res, options = list(main = "Seriation - threshold", threshold = 3)) @ In the resulting plot in Figure~\ref{fig:dissplot3}(b), we see that the block containing 10, 9, 5, 7, 8, 4 and 2 is very well defined and cleanly separated from the other block. This suggests that these clusters should form together a cluster in a solution with less clusters. The other block is less well defined. There is considerable overlap between clusters 6 and 3, but also cluster 3 and 1 share similar objects. Using the information stored in the result of \func{dissplot} and the class information available for the iris data set, we can analyze the cluster solution and the interpretations of the dissimilarity plot. <<>>= #names(res) table(iris[res$order, 5], res$label)[,res$cluster_order] #$ @ As the plot in Figure~\ref{fig:dissplot3} indicated, the clusters 10, 9, 5, 7, 8, 4 and 2 should be a single cluster containing only flowers of the species Iris setosa. The clusters 6, 3 and 1 are more problematic since they contain a mixture of Iris versicolor and virginica. To illustrate the results of the dissimilarity plot in case a clustering with a $k$ smaller than the actual number of groups in the data is used, we use the Ruspini data set which consists of 75 points in four groups and is also often used to illustrate clustering techniques. We load the data set, calculate distances, perform $k$-means clustering with $k=3$ (although the real number of groups is 4) and produce a dissimilarity plot. <>= data("ruspini", package = "cluster") d <- dist(ruspini) l <- kmeans(ruspini, 3)$cluster dissplot(d, labels = l) @ \begin{figure} \centering \includegraphics[width=10cm]{seriation-ruspini}\\ \caption{Dissimilarity plot for $k$-means solution with 3 clusters for the Ruspini data set with 4 groups.} \label{fig:ruspini} \end{figure} The dissimilarity plot in Figure~\ref{fig:ruspini} shows that cluster 3 actually should be two separate clusters represented by the two clearly visible darker triangles next to the main diagonal. The dissimilarity plot using seriation is a useful tool to inspect the result of clustering. It is especially useful to spot misspecifications of the number of clusters employed. A more detailed treatment of dissimilarity plots as a tool for exploring partitional clustering can be found in \cite{seriation:Hahsler+Kornik:2011}. \section{Conclusion} \label{sec:conclusion} In this paper we presented the infrastructure provided by the package~\pkg{seriation}. The infrastructure contains the necessary data structures to store the linear order for one-, two- and $k$-mode data. It also provides a wide array of seriation methods for different input data, e.g., dissimilarities, binary and general data matrices focusing on combinatorial optimization. New seriation methods can be easily incorporated into the \pkg{seriation} framework by the user with the method registry mechanism provided. Based on seriation, \pkg{seriation} features several visualization techniques. In particular, the optimally reordered heat map, the Bertin plot and the dissimilarity plot present clear improvements over standard plots. A natural extension to \pkg{seriation} is the synthesis of ensembles of seriations into a ``consensus'' one. Such ensembles do not only arise when using different seriation methods, but also when varying data or control parameters to obtain more robust solutions (see e.g.~\cite{seriation:Jurman:2008} for a recent application of such ideas in a molecular profiling context). The \proglang{R}~extension package \pkg{relations}~\citep{seriation:Hornik+Meyer:2008} contains a variety of methods for obtaining consensus \emph{relations}, covering consensus seriation (where the relations are linear orders on the objects) as a special case. Future work on \pkg{seriation} will focus on adding further seriation methods, such as for example methods for higher dimensional arrays and methods for block seriation which aim at finding simultaneous partitions of rows and columns in a data matrix~\citep[see, e.g.,][]{seriation:Marcotorchino:1987}. \section*{Acknowledgments} The authors would like to thank Michael Brusco, Hans-Friedrich K{\"o}hn and Stephanie Stahl for their seriation code, Fionn Murtagh for his BEA implementation and the anonymous reviewers for their valuable comments and suggestions. % %\bibliographystyle{abbrvnat} \bibliography{seriation} % \end{document} seriation/R/0000755000176200001440000000000014532141372012452 5ustar liggesusersseriation/R/ggVAT.R0000644000176200001440000000263414313070703013546 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. #' @rdname VAT #' @export ggVAT <- function(x, upper_tri = TRUE, lower_tri = TRUE, ...) { if (!inherits(x, "dist")) stop("x needs to be of class 'dist'!") ggpimage(x, seriate(x, "VAT"), upper_tri = upper_tri, lower_tri = lower_tri, ...) } #' @rdname VAT #' @export ggiVAT <- function(x, upper_tri = TRUE, lower_tri = TRUE, ...) { if (!inherits(x, "dist")) stop("x needs to be of class 'dist'!") x <- path_dist(x) ggpimage(x, seriate(x, "VAT"), upper_tri = upper_tri, lower_tri = lower_tri, ...) } seriation/R/seriate_reverse.R0000644000176200001440000000344314440720043015764 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. seriate_dist_reverse <- function(x, control) { control <- .get_parameters(control, NULL) rev(seq(attr(x, "Size"))) } seriate_matrix_reverse <- function(x, control, margin = seq_along(dim(x))) { control <- .get_parameters(control, NULL) lapply(seq_along(dim(x)), function(i) if (i %in% margin) rev(seq(dim(x)[i])) else NA ) } set_seriation_method("dist", "Reverse", seriate_dist_reverse, "Reversed identity permutation", optimized = "None") set_seriation_method("matrix", "Reverse", seriate_matrix_reverse, "Reversed identity permutation", optimized = "None") set_seriation_method("array", "Reverse", seriate_matrix_reverse, "Reversed identity permutation", optimized = "None") seriation/R/seriate_enumerate.R0000644000176200001440000000470614457041152016306 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. # utilities from package smacof next.perm <- function(x) .C("permNext", as.double(x), as.integer(length(x)), PACKAGE = "seriation")[[1]] are.monotone <- function(x, y) as.logical(.C( "isMon", as.double(x), as.double(y), as.integer(length(x)), as.integer(1), PACKAGE = "seriation" )[[4]]) .control_enumerate <- list(criterion = "Gradient_weighted", verbose = FALSE) attr(.control_enumerate, "help") <- list(criterion = "Criterion measure to optimize") seriate_dist_enumerate <- function(x, control = NULL) { control <- .get_parameters(control, .control_enumerate) n <- attr(x, "Size") perm <- seq(n) best_perm <- perm best_crit <- Inf suppressWarnings(m <- as.integer(factorial(n))) if (is.na(m)) stop("Number of permutations is too large.") k <- 0L if (control$verbose) cat("Permutation - of", m) repeat { k <- k + 1L if (control$verbose) { cat("\rPermutation", k, "of", m) } crit <- criterion(x, perm, method = control$criterion, force_loss = TRUE) if (crit < best_crit) { best_crit <- crit best_perm <- perm } #if (prod(perm==(n:1))==1) break if (k >= m) break perm <- next.perm(perm) } if (control$verbose) cat("\n") names(best_perm) <- attr(x, "Labels")[best_perm] best_perm } set_seriation_method( "dist", "Enumerate", seriate_dist_enumerate, "Enumerate all permutations", control = .control_enumerate, optimizes = .opt (NA, "set via control criterion)") ) seriation/R/ser_dist.R0000644000176200001440000003264414607605742014433 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. .dist_methods <- c("spearman", "kendall", "manhattan", "euclidean", "hamming", "ppc", "aprd") #' Dissimilarities and Correlations Between Seriation Orders #' #' Calculates dissimilarities/correlations between seriation orders in a list of type #' [ser_permutation_vector]. #' #' `ser_cor()` calculates the correlation between two sequences (orders). #' Note that a seriation order and its reverse are identical and purely an #' artifact due to the method that creates the order. This is a major #' difference to rankings. For ranking-based correlation measures (Spearman and #' Kendall) the absolute value of the correlation is returned for #' `reverse = TRUE` (in effect returning the correlation for the reversed order). If #' `test = TRUE` then the appropriate test for association is performed #' and a matrix with p-values is returned as the attribute `"p-value"`. #' Note that no correction for multiple testing is performed. #' #' For `ser_dist()`, the correlation coefficients (Kendall's tau and #' Spearman's rho) are converted into a dissimilarity by taking one minus the #' correlation value. Note that Manhattan distance between the ranks in a #' linear order is equivalent to Spearman's footrule metric (Diaconis 1988). #' `reverse = TRUE` returns the pairwise minima using also reversed #' orders. #' #' The positional proximity coefficient (ppc) is a precedence invariant measure #' based on product of the squared positional distances in two permutations #' defined as (see Goulermas et al 2016): #' #' \deqn{d_{ppc}(R, S) = 1/h \sum_{j=2}^n \sum_{i=1}^{j-1} #' (\pi_R(i)-\pi_R(j))^2 * (\pi_S(i)-\pi_S(j))^2,} #' #' where \eqn{R} and \eqn{S} are two seriation orders, \eqn{pi_R} and #' \eqn{pi_S} are the associated permutation vectors and \eqn{h} is a #' normalization factor. The associated generalized correlation coefficient is #' defined as \eqn{1-d_{ppc}}. For this precedence invariant measure #' `reverse` is ignored. #' #' The absolute pairwise rank difference (aprd) is also precedence invariant #' and defined as a distance measure: #' #' \deqn{d_{aprd}(R, S) = \sum_{j=2}^n \sum_{i=1}^{j-1} | |\pi_R(i)-\pi_R(j)| - #' |\pi_S(i)-\pi_S(j)| |^p,} #' #' where \eqn{p} is the power which can be passed on as parameter `p` and #' is by default set to 2. For this precedence invariant measure `reverse` #' is ignored. #' #' `ser_align()` tries to normalize the direction in a list of seriations #' such that ranking-based methods can be used. We add for each permutation #' also the reversed order to the set and then use a modified version of Prim's #' algorithm for finding a minimum spanning tree (MST) to choose if the #' original seriation order or its reverse should be used. We use the orders #' first added to the MST. Every time an order is added, its reverse is removed #' from the possible remaining orders. #' #' @family permutation #' #' @param x set of seriation orders as a list with elements which can be #' coerced into [ser_permutation_vector] objects. #' @param y if not `NULL` then a single seriation order can be specified. #' In this case `x` has to be a single seriation order and not a list. #' @param method a character string with the name of the used measure. #' Available measures are: `"kendall"`, `"spearman"`, #' `"manhattan"`, `"euclidean"`, `"hamming"`, `"ppc"` #' (positional proximity coefficient), and `"aprd"` (absolute pairwise #' rank differences). #' @param reverse a logical indicating if the orders should also be checked in #' reverse order and the best value (highest correlation, lowest distance) is #' reported. This only affect ranking-based measures and not precedence #' invariant measures (e.g., `"ppc"`, `"aprd"`). #' @param test a logical indicating if a correlation test should be performed. #' @param ... Further arguments passed on to the method. #' @return #' - `ser_dist()` returns an object of class [stats::dist]. #' - `ser_align()` returns a new list with elements of class #' [ser_permutation]. #' @author Michael Hahsler #' @references P. Diaconis (1988): _Group Representations in Probability and #' Statistics,_ Institute of Mathematical Statistics, Hayward, CA. #' #' J.Y. Goulermas, A. Kostopoulos, and T. Mu (2016): A New Measure for #' Analyzing and Fusing Sequences of Objects. _IEEE Transactions on #' Pattern Analysis and Machine Intelligence_ **38**(5):833-48. #' \doi{10.1109/TPAMI.2015.2470671} #' @keywords cluster #' @examples #' set.seed(1234) #' ## seriate dist of 50 flowers from the iris data set #' data("iris") #' x <- as.matrix(iris[-5]) #' x <- x[sample(1:nrow(x), 50), ] #' rownames(x) <- 1:50 #' d <- dist(x) #' #' ## Create a list of different seriations #' methods <- c("HC_complete", "OLO", "GW", "VAT", #' "TSP", "Spectral", "MDS", "Identity", "Random") #' #' os <- sapply(methods, function(m) { #' cat("Doing", m, "... ") #' tm <- system.time(o <- seriate(d, method = m)) #' cat("took", tm[3],"s.\n") #' o #' }) #' #' ## Compare the methods using distances. Default is based on #' ## Spearman's rank correlation coefficient where reverse orders are #' ## also considered. #' ds <- ser_dist(os) #' hmap(ds, margin = c(7,7)) #' #' ## Compare using correlation between orders. Reversed orders have #' ## negative correlation! #' cs <- ser_cor(os, reverse = FALSE) #' hmap(cs, margin = c(7,7)) #' #' ## Compare orders by allowing orders to be reversed. #' ## Now all but random and identity are highly positive correlated #' cs2 <- ser_cor(os, reverse = TRUE) #' hmap(cs2, margin=c(7,7)) #' #' ## A better approach is to align the direction of the orders first #' ## and then calculate correlation. #' os_aligned <- ser_align(os) #' cs3 <- ser_cor(os_aligned, reverse = FALSE) #' hmap(cs3, margin = c(7,7)) #' #' ## Compare the orders using clustering. We use Spearman's foot rule #' ## (Manhattan distance of ranks). In order to use rank-based method, #' ## we align the direction of the orders. #' os_aligned <- ser_align(os) #' ds <- ser_dist(os_aligned, method = "manhattan") #' plot(hclust(ds)) #' @export ser_dist <- function(x, y = NULL, method = "spearman", reverse = TRUE, ...) { method <- match.arg(tolower(method), .dist_methods) ## make sure everything is a permutation vector if (!is.null(y)) x <- list(ser_permutation_vector(x), ser_permutation_vector(y)) else x <- lapply(x, ser_permutation_vector) if (!reverse) switch( method, spearman = stats::as.dist(1 - ser_cor( x, method = "spearman", reverse = FALSE )), kendall = stats::as.dist(1 - ser_cor( x, method = "kendal", reverse = FALSE )), ### Manhattan == Spearman's footrule manhattan = stats::dist(t(.lget_rank(x)), method = "manhattan"), euclidean = stats::dist(t(.lget_rank(x)), method = "euclidean"), hamming = .dist_hamming(t(.lget_rank(x))), ppc = as.dist(1 - ser_cor( x, method = "ppc", reverse = FALSE )), aprd = stats::as.dist(.aprd(x, ...)) ) else switch( method, spearman = stats::as.dist(1 - ser_cor( x, method = "spearman", reverse = TRUE )), kendall = stats::as.dist(1 - ser_cor( x, method = "kendal", reverse = TRUE )), ### Manhattan == Spearman's footrule manhattan = .find_best(dist(t( .lget_rank(.add_rev(x)) ), method = "manhattan")), euclidean = .find_best(dist(t( .lget_rank(.add_rev(x)) ), method = "euclidean")), hamming = .find_best(.dist_hamming(t( .lget_rank(.add_rev(x)) ))), ### positional proximity coefficient is direction invariant ppc = stats::as.dist(1 - ser_cor( x, method = "ppc", reverse = FALSE )), aprd = stats::as.dist(.aprd(x, ...)) ) } #' @rdname ser_dist #' @export ser_cor <- function(x, y = NULL, method = "spearman", reverse = TRUE, test = FALSE) { ## Note: not all .dist_methods are implemented! method <- match.arg(tolower(method), .dist_methods) ## make sure everything is a permutation vector if (!is.null(y)) x <- list(ser_permutation_vector(x), ser_permutation_vector(y)) else x <- lapply(x, ser_permutation_vector) m <- .lget_rank(x) if (method == "ppc") { if (test) stop("No test for association available for PPC!") return(.ppc(x)) } ## cor based methods co <- stats::cor(m, method = method) if (reverse) co <- abs(co) ## add a correlation test? if (test) { p <- outer(1:ncol(m), 1:ncol(m), FUN = Vectorize(function(i, j) stats::cor.test(m[, i], m[, j], method = method)$p.value)) dimnames(p) <- dimnames(co) attr(co, "p-value") <- p } co } #' @rdname ser_dist #' @export ser_align <- function(x, method = "spearman") { if (!is.list(x)) stop("x needs to be a list with elements of type 'ser_permutation_vector'") x <- lapply(x, ser_permutation_vector) .do_rev(x, .alignment(x, method = method)) } .dist_hamming <- function(x) { n <- nrow(x) m <- matrix(nrow = n, ncol = n) for (i in seq_len(n)) for (j in seq(i, n)) m[j, i] <- m[i, j] <- sum(x[i, ] != x[j, ]) mode(m) <- "numeric" dimnames(m) <- list(rownames(x), rownames(x)) stats::as.dist(m) } ### make a permutation list into a rank matrix (cols are permutations) .lget_rank <- function(x) sapply(x, get_rank) ### add reversed permutations to a list of permutations .add_rev <- function(x) { os <- append(x, lapply(x, rev)) names(os) <- c(labels(x), paste(labels(x), "_rev", sep = "")) os } ### reverses permutations in the list given a logical indicator vector .do_rev <- function(x, rev) { for (i in which(rev)) x[[i]] <- rev(x[[i]]) x } ### finds the smallest distance in lists with reversed orders present .find_best <- function(d) { ### find smallest values m <- as.matrix(d) n <- nrow(m) / 2 m1 <- m[1:n, 1:n] m2 <- m[(n + 1):(2 * n), (n + 1):(2 * n)] m3 <- m[1:n, (n + 1):(2 * n)] m4 <- m[(n + 1):(2 * n), 1:n] stats::as.dist(pmin(m1, m2, m3, m4)) } ### find largest values in matrix .find_best_max <- function(d) { m <- as.matrix(d) n <- nrow(m) / 2 m1 <- m[1:n, 1:n] m2 <- m[(n + 1):(2 * n), (n + 1):(2 * n)] m3 <- m[1:n, (n + 1):(2 * n)] m4 <- m[(n + 1):(2 * n), 1:n] pmax(m1, m2, m3, m4) } ### x needs to be a list of ser_permutation_vectors ### returns TRUE for sequences which should be reversed .alignment <- function(x, method = "spearman") { method <- match.arg(tolower(method), .dist_methods) n <- length(x) ## calculate dist (orders + reversed orders) d <- as.matrix(ser_dist(.add_rev(x), method = method, reverse = FALSE)) diag(d) <- NA for (i in 1:n) { d[i, n + i] <- NA d[n + i, i] <- NA } ## start with closest pair take <- which(d == min(d, na.rm = TRUE), arr.ind = TRUE)[1, ] #d[, c(take, (take+n) %% (2*n))] <- NA ## mark order and complement as taken d[, c(take, (take + n) %% (2 * n))] <- Inf ## keep adding the closest while (length(take) < n) { t2 <- which(d[take, ] == min(d[take, ], na.rm = TRUE), arr.ind = TRUE)[1, 2] #d[, c(t2, (t2+n) %% (2*n))] <- NA ### closest to all #t2 <- which.min(colSums(d[take,], na.rm = T)) d[, c(t2, (t2 + n) %% (2 * n))] <- Inf take <- append(take, t2) } ## create indicator vector for the orders which need to be reversed take_ind <- logical(n) take_ind[take[take > n] - n] <- TRUE names(take_ind) <- names(x) take_ind } ## Propositional Proximity Coefficient (1 - generalized corr. coef.) ## Goulermas, Kostopoulos and Mu (2016). A new measure for analyzing and fusing ## sequences of objects, IEEE Transactions on Pattern Analysis and Machine ## Intelligence 38(5):833-48. ## ## x,y ... permutation vectors (ranks) .vppc <- Vectorize(function(x, y) { x <- get_rank(x) y <- get_rank(y) n <- length(x) #sum <- 0 #for(j in 2:n) for(i in 1:(j-1)) sum <- sum + (x[i]-x[j])^2 * (y[i]-y[j])^2 ## use fast matrix algebra instead Ax <- (x %*% rbind(rep_len(1, n)) - tcrossprod(cbind(rep_len(1, n)), x)) ^ 2 Ay <- (y %*% rbind(rep_len(1, n)) - tcrossprod(cbind(rep_len(1, n)), y)) ^ 2 ## note: Ay is symetric sum <- sum(diag(Ax %*% Ay)) ## scale by theoretical maximum zapsmall(sum / (n ^ 6 / 15 - n ^ 4 / 6 + n ^ 2 / 10)) }) .ppc <- function(x) outer(x, x, .vppc) # Sum of differences of rank differences # # distance(R, S) = # \sum_{i,j} | |\pi_R(i)-\pi_R(j)| - |\pi_S(i)-\pi_S(j)| |^p # .vaprd <- Vectorize(function(x, y, p = 2) { x <- get_rank(x) y <- get_rank(y) n <- length(x) sum <- 0 for (j in 2:n) for (i in 1:(j - 1)) sum <- sum + abs(abs(x[i] - x[j]) - abs(y[i] - y[j])) ^ p ## FIXME: scale by theoretical maximum? sum }) .aprd <- function(x, p = 2) outer(x, x, .vaprd, p = p) seriation/R/seriate_SPIN.R0000644000176200001440000001463714457043555015107 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ## SPIN (Tsafrir et al. 2005) ## Weight matrix ## pimage(create_x(n=150, sigma=20, verbose=TRUE)) create_W <- function(n, sigma, verbose = FALSE) { w <- function(i, j, n, sigma) exp(-1 * (i - j) ^ 2 / n / sigma) W <- outer(1:n, 1:n, FUN = w, n = n, sigma = sigma) ## make doubly stochastic for (i in 1:1000) { #cat(i, ".") W <- sweep(W, MARGIN = 1, STATS = rowSums(W), "/") W <- sweep(W, MARGIN = 2, STATS = colSums(W), "/") if (all(round(rowSums(W), 5) == 1) && all(round(colSums(W), 5) == 1)) break } if (verbose) cat("It took", i, "iterations to make W doubly stochastic!\n") if (i > 999) warning("Weight matrix did not converge to doubly stochastic in 1000 itermation!") W } .spin_contr <- structure( list( sigma = floor(seq(20, 1, length.out = 10)), step = 5, W_function = NULL, verbose = FALSE ), help = list( sigma = "emphasize local (small alpha) or global (large alpha) structure.", step = "iterations to run for each sigma value.", W_function = "custom function to create the weight matrix W" ) ) ## SPIN: Neighborhood algorithms seriate_dist_SPIN <- function(x, control = NULL) { param <- .get_parameters(control, .spin_contr) W_function <- if (is.null(param$W_function)) create_W else param$W_function sigma <- param$sigma step <- param$step verbose <- param$verbose D <- as.matrix(x) n <- nrow(D) ## weight matrix W <- W_orig <- W_function(n, sigma[1], verbose) energy_best <- Inf for (i in 1:(length(sigma) * step)) { if (verbose) cat("Iteration", i, "... ") M <- D %*% W ## heuristic for the linear assignment problem ## (second argument to order breaks ties randomly) P <- permutation_vector2matrix(order(apply(M, MARGIN = 1, which.min), sample(1:n))) #if(verbose) print(table(apply(M, MARGIN = 1, which.min))) energy_new <- sum(diag(P %*% M)) if (verbose) cat("best energy:", energy_best, "new energy: ", energy_new, "\n") ## was energy improved? if (energy_new < energy_best) { energy_best <- energy_new P_best <- P } ## adapt sigma if (!(i %% step) && i != length(sigma) * step) { s <- sigma[i / step + 1] if (verbose) cat("\nReducing sigma to:", s, "\n") W_orig <- W_function(n, s, verbose) ## recalculate best energy W <- crossprod(P, W_orig) ### t(P) %*% W M <- D %*% W energy_best <- sum(diag(P %*% M)) if (verbose) cat("best energy is now:", energy_best, "\n\n") } else { W <- crossprod(P, W_orig) ### t(P) %*% W } } if (verbose) cat("Best Energy:", energy_best, "\n") o <- permutation_matrix2vector(P_best) o } ## SPIN: Side-to-Side algorithm ## this is the weight: pimage(tcrossprod(1:n - (n+1)/2)) .spin_sts_contr <- structure( list( step = 25L, nstart = 10L, X = function(n) seq(n) - (n + 1) / 2, verbose = FALSE ), help = list(step = "iterations to run", nstart = "number of random restarts", X = "matrix to calculate the W matrix") ) seriate_dist_SPIN_STS <- function(x, control = NULL) { param <- .get_parameters(control, .spin_sts_contr) step <- param$step verbose <- param$verbose nstart <- param$nstart X <- param$X D <- as.matrix(x) n <- nrow(D) ## X for weights W = X %*% t(X) (column vector) if (is.function(X)) X <- X(n) if (!is.numeric(X) || length(X) != n) stop("Invalid weight vector X.") W <- tcrossprod(X) ## X %*% t(X) .STS_run <- function() { if (verbose) cat("\nStarting new run\n") ## start with random permutation o_best <- o <- sample(1:n) #P_best <- P <- permutation_vector2matrix(o) #X_current <- crossprod(P, X) X_current <- X[o] #energy_best <- sum(diag(P %*% D %*% t(P) %*% W)) energy_best <- sum(diag(D[o, o] %*% W)) for (i in 1:step) { if (verbose) cat("Iteration", i, "... ") ## permutation matrix that orders S in descending order (break ties) S <- D %*% X_current o <- order(S, sample(1:n), decreasing = TRUE) #P <- permutation_vector2matrix(o) #X_current <- crossprod(P, X) ## t(P) %*% X X_current <- X[o] ## t(P) %*% X ## calculate energy F(P) #energy_new <- sum(diag(P %*% D %*% t(P) %*% W)) energy_new <- sum(diag(D[o, o] %*% W)) if (verbose) cat("best energy:", energy_best, "new energy: ", energy_new) ## was energy improved? if (energy_new < energy_best) { energy_best <- energy_new #P_best <- P o_best <- o if (verbose) cat(" - update") } if (verbose) cat("\n") } if (verbose) cat("Best Energy:", energy_best, "\n") #o <- permutation_matrix2vector(P_best) o <- o_best attr(o, "energy") <- energy_best o } res <- replicate(nstart, .STS_run(), simplify = FALSE) energy <- sapply(res, attr, "energy") if (verbose) cat("Overall best Energy:", min(energy), "\n") o <- res[[which.min(energy)]] o } set_seriation_method( "dist", "SPIN_NH", seriate_dist_SPIN, "Sorting Points Into Neighborhoods (SPIN) (Tsafrir 2005). Neighborhood algorithm to concentrate low distance values around the diagonal.", .spin_contr, optimizes = .opt(NA, "Energy") ) set_seriation_method( "dist", "SPIN_STS", seriate_dist_SPIN_STS, "Sorting Points Into Neighborhoods (SPIN) (Tsafrir 2005). Side-to-Side algorithm which tries to push out large distance values.", .spin_sts_contr, optimizes = .opt(NA, "Energy") ) seriation/R/ggdissplot.R0000644000176200001440000001116714455540124014764 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. #' @rdname dissplot #' @export ggdissplot <- function(x, labels = NULL, method = "spectral", control = NULL, lower_tri = TRUE, upper_tri = "average", diag = TRUE, cluster_labels = TRUE, cluster_lines = TRUE, reverse_columns = FALSE, ...) { check_installed("ggplot2") # make x dist if (!inherits(x, "dist")) { if (is.matrix(x) && isSymmetric(x)) x <- as.dist(x) else stop("Argument 'x' cannot safely be coerced to class 'dist'.") } x <- .arrange_dissimilarity_matrix(x, labels = labels, method = method, control = control) m <- .average_tri(x, lower_tri = lower_tri, upper_tri = upper_tri, diag = diag) k <- x$k dim <- attr(x$x_reordered, "Size") labels <- x$labels labels_unique <- unique(labels) # So we can add cluster labels later if (cluster_labels) colnames(m) <- seq(ncol(m)) g <- ggpimage(m, reverse_columns = reverse_columns, prop = TRUE, ...) # add cluster lines and labels if (!is.null(labels)) { cluster_width <- tabulate(labels)[labels_unique] cluster_cuts <- cumsum(cluster_width) cluster_center <- cluster_cuts - cluster_width / 2 clusters <- data.frame( center = cluster_center, cut = cluster_cuts, width = cluster_width, label = labels_unique ) ### NULLIFY for CRAN check center <- label <- cut <- NULL if (cluster_labels) { # Place cluster labels along diagonal # if (!flip) { # g <- g + ggplot2::geom_label(data = clusters, # ggplot2::aes( # x = center, # y = nrow(m) - center, # label = label # )) # } else{ # g <- g + ggplot2::geom_label(data = clusters, # ggplot2::aes( # x = ncol(m) - center, # y = nrow(m) - center, # label = label # )) # } # Place cluster labels on top as x-axis (needs the colnames set as a sequence) # this uses the row name not the position so no reordering is necessary # if (reverse_columns) { # breaks <- floor(clusters$center) # label_o <- order(breaks) # labels <- clusters$label[label_o] # breaks <- breaks[label_o] # } else { labels <- clusters$label breaks <- floor(clusters$center) # } # suppress redefinition message suppressMessages( g <- g + ggplot2::scale_x_discrete( breaks = breaks, label = as.character(labels), expand = c(0, 0), position = "top" ) + ggplot2::theme(axis.text.x = ggplot2::element_text( angle = 0, vjust = 0.5, hjust = .5 )) + ggplot2::labs(x = "Cluster") ) if (cluster_lines) { ## draw lines separating the clusters if (reverse_columns) { g <- g + ggplot2::geom_hline(data = clusters, ggplot2::aes(yintercept = nrow(m) - cut + .5)) + ggplot2::geom_vline(data = clusters, ggplot2::aes(xintercept = ncol(m) - cut + .5)) } else{ g <- g + ggplot2::geom_hline(data = clusters, ggplot2::aes(yintercept = nrow(m) - cut + .5)) + ggplot2::geom_vline(data = clusters, ggplot2::aes(xintercept = cut + .5)) } } } } # reverse color suppressMessages(g <- g + .gg_sequential_pal(dist = TRUE)) g } seriation/R/Zoo.R0000644000176200001440000000325414607605460013356 0ustar liggesusers#' Zoo Data Set #' #' A database containing characteristics of different animals. The database was #' created and donated by Richard S. Forsyth and is available from the UCI #' Machine Learning Repository (Newman et al, 1998). #' #' #' @name Zoo #' @family data #' @docType data #' @format #' A data frame with 101 observations on the following 17 variables. #' \describe{ #' \item{\code{hair}}{a numeric vector} #' \item{\code{feathers}}{a numeric vector} #' \item{\code{eggs}}{a numeric vector} #' \item{\code{milk}}{a numeric vector} #' \item{\code{airborne}}{a numeric vector} #' \item{\code{aquatic}}{a numeric vector} #' \item{\code{predator}}{a numeric vector} #' \item{\code{toothed}}{a numeric vector} #' \item{\code{backbone}}{a numeric vector} #' \item{\code{breathes}}{a numeric vector} #' \item{\code{venomous}}{a numeric vector} #' \item{\code{fins}}{a numeric vector} #' \item{\code{legs}}{a numeric vector} #' \item{\code{tail}}{a numeric vector} #' \item{\code{domestic}}{a numeric vector} #' \item{\code{catsize}}{a numeric vector} #' \item{\code{class}}{a factor with levels \code{amphibian} \code{bird} \code{fish} \code{insect} \code{invertebrate} \code{mammal} \code{reptile}} #' } #' @source David Aha, Patrick Murphy, Christopher Merz, Eamonn Keogh, #' Cathy Blake, Seth Hettich, David Newman, Arthur Asuncion, Moshe Lichman, #' Dheeru Dua, Casey Graff (2023): UCI Machine Learning Repository, #' \url{https://archive.ics.uci.edu/}, University of #' California, Irvine. #' @keywords datasets #' @examples #' data("Zoo") #' x <- scale(Zoo[, -17]) #' #' #' d <- dist(x) #' pimage(d) #' #' order <- seriate(d, method = "tsp") #' pimage(d, order) NULL seriation/R/pimage.R0000644000176200001440000004010614456631671014053 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ## image method that makes a proper image plot of a matrix. ## the rows and columns are swapped and the order of the ## columns (original rows) is reversed. #' Permutation Image Plot #' #' Provides methods for matrix shading, i.e., displaying a color image for #' matrix (including correlation matrices and data frames) and `dist` objects given an #' optional permutation. The plot arranges colored rectangles to represent the #' values in the matrix. This visualization is also know as a heatmap. #' Implementations based on the #' \pkg{grid} graphics engine and based n \pkg{ggplot2} are provided. #' #' Plots a matrix in its original row and column orientation ([image] in \pkg{stats} #' reverses the rows). This means, in a #' plot the columns become the x-coordinates and the rows the y-coordinates (in #' reverse order). #' #' **Grid-based plot:** The viewports used for plotting are called: #' `"plot"`, `"image"` and `"colorkey"`. Use \pkg{grid} functions #' to manipulate the plots (see Examples section). #' #' **ggplot2-based plot:** A ggplot2 object is returned. Colors, axis limits #' and other visual aspects can be added using standard ggplot2 functions #' (`labs`, `scale_fill_continuous`, `labs`, etc.). #' #' @family plots #' #' @param x a matrix, a data.frame, or an object of class `dist`. #' @param order a logical where `FALSE` means no reordering and `TRUE` applies #' a permutation using the default seriation method for the type of `x`. Alternatively, #' any object that can be coerced to class `ser_permutation` #' can be supplied. #' @param col a list of colors used. If `NULL`, a gray scale is used (for #' matrix larger values are displayed darker and for `dist` smaller #' distances are darker). For matrices containing logical data, black and white #' is used. For matrices containing negative values a symmetric diverging color #' palette is used. #' @param main plot title. #' @param xlab,ylab labels for the x and y axes. #' @param zlim vector with two elements giving the range (min, max) for #' representing the values in the matrix. #' @param key logical; add a color key? No key is available for logical #' matrices. #' @param keylab string plotted next to the color key. #' @param symkey logical; if `x` contains negative values, should the #' color palate be symmetric (zero is in the middle)? #' @param upper_tri,lower_tri,diag a logical indicating whether to show the #' upper triangle, the lower triangle or the diagonal of the (distance) matrix. #' @param row_labels,col_labels a logical indicating if row and column labels #' in `x` should be displayed. If `NULL` then labels are displayed #' if the `x` contains the appropriate dimname and the number of labels is #' 25 or less. A character vector of the appropriate length with labels can #' also be supplied. #' @param prop logical; change the aspect ratio so cells in the image have a #' equal width and height. #' @param flip_axes logical; exchange rows and columns for plotting. #' @param reverse_columns logical; revers the order of how the columns are #' displayed. #' @param \dots if `order` is the name of a seriation method then further arguments are passed #' on to the seriation method, otherwise they are ignored. #' @param newpage,pop,gp Start plot on a new page, pop the viewports after #' plotting, and use the supplied `gpar` object (see \pkg{grid}). #' @returns Nothing. #' #' @author Christian Buchta and Michael Hahsler #' @keywords hplot #' @examples #' set.seed(1234) #' data(iris) #' x <- as.matrix(iris[sample(nrow(iris), 20) , -5]) #' #' pimage(x) #' #' # Show all labels and flip axes, reverse columns, or change colors #' pimage(x, prop = TRUE) #' pimage(x, flip_axes = TRUE) #' pimage(x, reverse_columns = TRUE) #' pimage(x, col = grays(100)) #' #' # A matrix with positive and negative values #' x_scaled <- scale(x) #' pimage(x_scaled) #' #' # Use reordering #' pimage(x_scaled, order = TRUE) #' pimage(x_scaled, order = "Heatmap") #' #' ## Example: Distance Matrix #' # Show a reordered distance matrix (distances between rows). #' # Dark means low distance. The aspect ratio is automatically fixed to 1:1 #' # using prop = TRUE #' d <- dist(x) #' pimage(d) #' pimage(d, order = TRUE) #' #' # Supress the upper triangle and diagonal #' pimage(d, order = TRUE, upper = FALSE, diag = FALSE) #' #' # Show only distances that are smaller than 2 using limits on z. #' pimage(d, order = TRUE, zlim = c(0, 3)) #' #' ## Example: Correlation Matrix #' # we calculate correlation between rows and seriate the matrix #' # and seriate by converting the correlations into distances. #' # pimage reorders then rows and columns with c(o, o). #' r <- cor(t(x)) #' o <- seriate(as.dist(sqrt(1 - r))) #' pimage(r, order = c(o, o), #' upper = FALSE, diag = FALSE, #' zlim = c(-1, 1), #' reverse_columns = TRUE, #' main = "Correlation matrix") #' #' # Add to the plot using functions in package grid #' # Note: pop = FALSE allows us to manipulate viewports #' library("grid") #' pimage(x, order = TRUE, pop = FALSE) #' #' # available viewports are: "main", "colorkey", "plot", "image" #' current.vpTree() #' #' # Highlight cell 2/2 with a red arrow #' # Note: columns are x and rows are y. #' downViewport(name = "image") #' grid.lines(x = c(1, 2), y = c(-1, 2), arrow = arrow(), #' default.units = "native", gp = gpar(col = "red", lwd = 3)) #' #' # add a red box around the first 4 rows of the 2nd column #' grid.rect(x = 1 + .5 , y = 4 + .5, width = 1, height = 4, #' hjust = 0, vjust = 1, #' default.units = "native", gp = gpar(col = "red", lwd = 3, fill = NA)) #' #' ## remove the viewports #' popViewport(0) #' #' ## put several pimages on a page (use grid viewports and newpage = FALSE) #' # set up grid layout #' library(grid) #' grid.newpage() #' top_vp <- viewport(layout = grid.layout(nrow = 1, ncol = 2, #' widths = unit(c(.4, .6), unit = "npc"))) #' col1_vp <- viewport(layout.pos.row = 1, layout.pos.col = 1, name = "col1_vp") #' col2_vp <- viewport(layout.pos.row = 1, layout.pos.col = 2, name = "col2_vp") #' splot <- vpTree(top_vp, vpList(col1_vp, col2_vp)) #' pushViewport(splot) #' #' seekViewport("col1_vp") #' o <- seriate(d) #' pimage(x, c(o, NA), col_labels = FALSE, main = "Data", #' newpage = FALSE) #' #' seekViewport("col2_vp") #' ## add the reordered dissimilarity matrix for rows #' pimage(d, o, main = "Distances", #' newpage = FALSE) #' #' popViewport(0) #' #' ##------------------------------------------------------------- #' ## ggplot2 Examples #' if (require("ggplot2")) { #' #' library("ggplot2") #' #' set.seed(1234) #' data(iris) #' x <- as.matrix(iris[sample(nrow(iris), 20) , -5]) #' #' ggpimage(x) #' #' # Show all labels and flip axes, reverse columns #' ggpimage(x, prop = TRUE) #' ggpimage(x, flip_axes = TRUE) #' ggpimage(x, reverse_columns = TRUE) #' #' #' # A matrix with positive and negative values #' x_scaled <- scale(x) #' ggpimage(x_scaled) #' #' # Use reordering #' ggpimage(x_scaled, order = TRUE) #' ggpimage(x_scaled, order = "Heatmap") #' #' ## Example: Distance Matrix #' # Show a reordered distance matrix (distances between rows). #' # Dark means low distance. The aspect ratio is automatically fixed to 1:1 #' # using prop = TRUE #' d <- dist(x) #' ggpimage(d) #' ggpimage(d, order = TRUE) #' #' # Supress the upper triangle and diagonal #' ggpimage(d, order = TRUE, upper = FALSE, diag = FALSE) #' #' # Show only distances that are smaller than 2 using limits on z. #' ggpimage(d, order = TRUE, zlim = c(0, 2)) #' #' ## Example: Correlation Matrix #' # we calculate correlation between rows and seriate the matrix #' r <- cor(t(x)) #' o <- seriate(as.dist(sqrt(1 - r))) #' ggpimage(r, order = c(o, o), #' upper = FALSE, diag = FALSE, #' zlim = c(-1, 1), #' reverse_columns = TRUE) + labs(title = "Correlation matrix") #' #' ## Example: Custom themes and colors #' # Reorder matrix, use custom colors, add a title, #' # and hide colorkey. #' ggpimage(x) + #' theme(legend.position = "none") + #' labs(title = "Random Data") + xlab("Variables") #' #' # Add lines #' ggpimage(x) + #' geom_hline(yintercept = seq(0, nrow(x)) + .5) + #' geom_vline(xintercept = seq(0, ncol(x)) + .5) #' #' # Use ggplot2 themes with theme_set #' old_theme <- theme_set(theme_linedraw()) #' ggpimage(d) #' theme_set(old_theme) #' #' # Use custom color palettes: Gray scale, Colorbrewer (provided in ggplot2) and colorspace #' ggpimage(d, order = seriate(d), upper_tri = FALSE) + #' scale_fill_gradient(low = "black", high = "white", na.value = "white") #' #' ggpimage(d, order = seriate(d), upper_tri = FALSE) + #' scale_fill_distiller(palette = "Spectral", direction = +1, na.value = "white") #' #' ggpimage(d, order = seriate(d), upper_tri = FALSE) + #' colorspace::scale_fill_continuous_sequential("Reds", rev = FALSE, na.value = "white") #' } #' @export pimage <- function(x, order = FALSE, ...) UseMethod("pimage") ### Note for matrix large values are dark, for dist large values are light! #' @rdname pimage #' @export pimage.matrix <- function(x, order = FALSE, col = NULL, main = "", xlab = "", ylab = "", zlim = NULL, key = TRUE, keylab = "", symkey = TRUE, upper_tri = TRUE, lower_tri = TRUE, diag = TRUE, row_labels = NULL, col_labels = NULL, prop = isSymmetric(x), flip_axes = FALSE, reverse_columns = FALSE, ..., newpage = TRUE, pop = TRUE, gp = NULL) { force(prop) x <- as.matrix(x) # check data if (all(is.na(x))) stop("all data missing in x.") if (any(is.infinite(x))) stop("x contains infinite entries.") # set default values # no key for logical data! if (is.logical(x)) key <- FALSE if (is.null(col)) { if (is.logical(x)) col <- c("white", "black") else { if (!is.null(zlim)) { if (min(zlim) < 0) col <- .diverge_pal(100) else col <- .sequential_pal(100) } else { if (any(x < 0, na.rm = TRUE)) { col <- .diverge_pal(100) zlim <- max(abs(range(x, na.rm = TRUE))) * c(-1, 1) } else col <- .sequential_pal(100) } } } if (is.null(prop)) prop <- FALSE if (is.null(gp)) gp <- gpar() if (is.null(zlim)) zlim <- range(x, na.rm = TRUE) # reorder if (!is.null(order)) x <- permute(x, order, ...) # mask triangles if (any(!upper_tri || !lower_tri || !diag) && nrow(x) != ncol(x)) stop("Upper triange, lower triangle or diagonal can only be suppressed for square matrices!") if (!upper_tri) x[upper.tri(x)] <- NA if (!lower_tri) x[lower.tri(x)] <- NA if (!diag) diag(x) <- NA # change x and y if (flip_axes) { x <- t(x) tmp <- row_labels row_labels <- col_labels col_labels <- tmp } # reverse order of columns if (reverse_columns) x <- x[, seq(ncol(x), 1)] # deal with row/col labels if (!is.null(row_labels) && !is.logical(row_labels)) { if (length(row_labels) != nrow(x)) stop("Length of row_labels does not match the number of rows of x.") rownames(x) <- row_labels row_labels <- TRUE } if (!is.null(col_labels) && !is.logical(col_labels)) { if (length(col_labels) != ncol(x)) stop("Length of col_labels does not match the number of columns of x.") colnames(x) <- col_labels col_labels <- TRUE } if (is.null(row_labels)) if (!is.null(rownames(x)) && nrow(x) < 25) { row_labels <- TRUE } else{ row_labels <- FALSE } if (is.null(col_labels)) if (!is.null(colnames(x)) && ncol(x) < 25) { col_labels <- TRUE } else{ col_labels <- FALSE } if (is.null(rownames(x))) rownames(x) <- seq(nrow(x)) if (is.null(colnames(x))) colnames(x) <- seq(ncol(x)) # create layout for plot bottom_mar <- if (col_labels) max(stringWidth(colnames(x))) + unit(3, "lines") else unit(1, "lines") left_mar <- if (row_labels) max(stringWidth(rownames(x))) + unit(3, "lines") else unit(1, "lines") if (newpage) grid.newpage() if (key) { .grid_basic_layout_with_colorkey( main = main, left = left_mar, right = unit(0, "lines"), bottom = bottom_mar, gp = gp ) down <- downViewport("colorkey") .grid_colorkey(zlim, col = col, horizontal = FALSE, lab = keylab) upViewport(down) } else .grid_basic_layout( main = main, left = left_mar, right = unit(0, "lines"), bottom = bottom_mar, gp = gp ) down <- downViewport("plot") .grid_image( x, col = col, zlim = zlim, prop = prop ) #, gp=gp) upViewport(down) ## axes and labs down <- downViewport("image") if (col_labels) grid.text( colnames(x), y = unit(-1, "lines"), x = unit(1:ncol(x), "native"), rot = 90, just = "right" ) #, gp=gp) #grid.xaxis(at=1:ncol(x), # label=colnames(x)) if (row_labels) grid.text( rownames(x), x = unit(-1, "lines"), y = unit(1:nrow(x), "native"), just = "right" ) #, gp=gp) #grid.yaxis(at=1:nrow(x), # label=rownames(x)) if (xlab != "") grid.text(xlab, y = -1 * bottom_mar + unit(1, "lines")) #, gp=gp) if (ylab != "") grid.text(ylab, x = ,-1 * left_mar + unit(1, "lines"), rot = 90) #, gp=gp) # it is always 2 up from main seekViewport("main") down <- 2 if (pop) popViewport(down) else upViewport(down) } #' @export pimage.default <- pimage.matrix # as.matrix does not work for table! table2matrix <- function(M) matrix(M, ncol = ncol(M), dimnames = dimnames(M)) #' @rdname pimage #' @export pimage.table <- function(x, order = NULL, ...) pimage.matrix(table2matrix(x), order = order, ...) #' @rdname pimage #' @export pimage.data.frame <- function(x, order = NULL, ...) pimage.matrix(as.matrix(x), order = order, ...) ## small values are dark #' @rdname pimage #' @export pimage.dist <- function(x, order = NULL, col = NULL, main = "", xlab = "", ylab = "", zlim = NULL, key = TRUE, keylab = "", symkey = TRUE, upper_tri = TRUE, lower_tri = TRUE, diag = TRUE, row_labels = NULL, col_labels = NULL, prop = TRUE, flip_axes = FALSE, reverse_columns = FALSE, ..., newpage = TRUE, pop = TRUE, gp = NULL) { if (is.null(col)) col <- rev(.sequential_pal(100)) else col <- rev(col) if (is.null(prop)) prop <- TRUE if (!is.null(order)) x <- permute(x, order, ...) if (flip_axes) warning("flip_axes has no effect for distance matrices.") pimage.matrix( x, order = NULL, # already reordered main = main, xlab = xlab, ylab = ylab, col = col, zlim = zlim, key = key, keylab = keylab, symkey = symkey, upper_tri = upper_tri, lower_tri = lower_tri, diag = diag, row_labels = row_labels, col_labels = col_labels, prop = prop, flip_axes = FALSE, reverse_columns = reverse_columns, ..., newpage = newpage, pop = pop, gp = gp ) } seriation/R/AAA_check_installed.R0000644000176200001440000000263214313070703016352 0ustar liggesusers## This is a modified version from package rlang that only uses base R functionality. ## action can be "install" (from CRAN), "stop" (with message), "check" (returns TRUE/FALSE) ## manual can be either TRUE or a string with installation instructions. check_installed <- function (pkg, action = "install", message = NULL) { action <- match.arg(action, choices = c("install", "stop", "check")) if (!is.character(pkg)) stop("`pkg` must be a package name or a vector of package names.") needs_install <- sapply(pkg, function(x) ! requireNamespace(x, quietly = TRUE)) if (action == "check") return(!any(needs_install)) if (any(needs_install)) { if (!interactive()) stop(info) missing_pkgs <- pkg[needs_install] missing_pkgs_enum <- paste(missing_pkgs, collapse = ", ") info <- paste("The", missing_pkgs_enum, "package(s) is/are required.") if (action == "install") { question <- "Would you like to install the package(s)?" cat(info, "\n", question, sep = '') if (utils::menu(c("Yes", "No")) != 1) { invokeRestart("abort") } utils::install.packages(missing_pkgs) } else { ### this is stop cat(info, "\n", message, sep = '') invokeRestart("abort") } } invisible(TRUE) } seriation/R/bertinplot.R0000644000176200001440000003315614456113154014771 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. #' Plot a Bertin Matrix #' #' Plot a data matrix of cases and variables. Each value is represented by a #' symbol. Large values are highlighted. Note that Bertin arranges the cases #' horizontally and the variables as rows. The matrix can be rearranged using #' seriation techniques to make structure in the data visible (see Falguerolles #' et al 1997). #' #' The plot is organized as a matrix of symbols. The symbols are drawn by a #' panel function, where all symbols of a row are drawn by one call of the #' function (using vectorization). The interface for the panel function is #' `panel.myfunction(value, spacing, hl)`. `value` is the vector of #' values for a row scaled between 0 and 1, `spacing` contains the #' relative space between symbols and `hl` is a logical vector indicating #' which symbol should be highlighted. #' #' Cut lines can be added to an existing Bertin plot using #' `bertin_cut_line(x = NULL, y = NULL)`. `x`/`y` is can be a #' number indicating where to draw the cut line between two columns/rows. If #' both `x` and `y` is specified then one can select a row/column and #' the other can select a range to draw a line which does only span a part of #' the row/column. It is important to call `bertinplot()` with the option #' `pop = FALSE`. #' #' `ggbertinplot()` calls [ggpimage()] and all additional parameters are #' passed on. #' #' @family plots #' @param x a data matrix. Note that following Bertin, columns are variables #' and rows are cases. This behavior can be reversed using `reverse = TRUE` #' in `options`. #' @param order an object of class `ser_permutation` to rearrange `x` #' before plotting. If `NULL`, no rearrangement is performed. #' @param panel.function a function to produce the symbols. Currently available #' functions are `panel.bars` (default), `panel.circles`, #' `panel.rectangles`, `panel.tiles` and `panel.lines`. For #' circles and squares neg. values are represented by a dashed border. For #' blocks all blocks are the same size (can be used with `shading = TRUE`). #' @param geom visualization type. Available ggplot2 geometries are: `"tile"`, #' `"rectangle"`, `"circle"`, `"line"`, `"bar"`, `"none"`. #' @param highlight a logical scalar indicating whether to use highlighting. #' If `TRUE`, all variables with values greater than the variable-wise #' mean are highlighted. To control highlighting, also a logical matrix or a #' matrix with colors with the same dimensions as `x` can be supplied. #' @param row_labels,col_labels a logical indicating if row and column labels #' in `x` should be displayed. If `NULL` then labels are displayed #' if the `x` contains the appropriate dimname and the number of labels is #' 25 or less. A character vector of the appropriate length with labels can #' also be supplied. #' @param flip_axes logical indicating whether to swap cases and variables in #' the plot. The default (`TRUE`) is to plot cases as columns and #' variables as rows. #' @param prop logical; change the aspect ratio so cells in the image have a #' equal width and height. #' @param col,y and x in `bertin_cut_line()` are for adding a line to a `bertinplot()` (not ggplot2-based). #' @param value,spacing,hl are used internally for the panel functions. #' @param ... #' `ggbertinplot()`: further parameters are passed on to [ggpimage()]. #' #' `bertinplot()`: further parameters can include: #' - `xlab, ylab` labels (default: use labels from `x`). #' - `spacing` relative space between symbols (default: 0.2). #' - `shading` use gray shades to encode value instead of #' highlighting (default: `FALSE`). #' - `shading.function` a function that accepts a single argument in range \eqn{[.1, .8]} #' and returns a valid corresponding color (e.g., using [rgb()]). #' - `frame` plot a grid to separate symbols (default: `FALSE`). #' - `mar` margins (see [par()]). #' - `gp_labels` `gpar` object for labels (see [gpar()]) #' - `gp_panels` `gpar` object for panels (see [gpar()]). #' - `newpage` a logical indicating whether to start #' the plot on a new page (see [grid.newpage()]). #' - `pop` a logical indicating whether to pop the created viewports #' (see [pop.viewport()])? #' #' @returns Nothing. #' #' @author Michael Hahsler #' @references de Falguerolles, A., Friedrich, F., Sawitzki, G. (1997): A #' Tribute to J. Bertin's Graphical Data Analysis. In: Proceedings of the #' SoftStat '97 (Advances in Statistical Software 6), 11--20. #' @keywords hplot cluster #' @examples #' data("Irish") #' scale_by_rank <- function(x) apply(x, 2, rank) #' x <- scale_by_rank(Irish[,-6]) #' #' # Use the the sum of absolute rank differences #' order <- c( #' seriate(dist(x, "minkowski", p = 1)), #' seriate(dist(t(x), "minkowski", p = 1)) #' ) #' #' # Plot #' bertinplot(x, order) #' #' # Some alternative displays #' bertinplot(x, order, panel = panel.tiles, shading_col = bluered(100), highlight = FALSE) #' bertinplot(x, order, panel = panel.circles, spacing = -.2) #' bertinplot(x, order, panel = panel.rectangles) #' bertinplot(x, order, panel = panel.lines) #' #' # Plot with cut lines (we manually set the order here) #' order <- ser_permutation(c(6L, 9L, 29L, 10L, 32L, 22L, 2L, 35L, #' 24L, 30L, 33L, 25L, 37L, 36L, 8L, 27L, 4L, 39L, 3L, 40L, 38L, #' 1L, 31L, 34L, 28L, 23L, 5L, 11L, 7L, 41L, 13L, 26L, 17L, 15L, #' 12L, 20L, 14L, 18L, 19L, 16L, 21L), #' c(4L, 2L, 1L, 6L, 7L, 8L, 5L, 3L)) #' #' bertinplot(x, order, pop=FALSE) #' bertin_cut_line(, 4) ## horizontal line between rows 4 and 5 #' bertin_cut_line(, 7) ## separate "Right to Life" from the rest #' bertin_cut_line(18, c(0, 4)) ## separate a block of large values (vertically) #' #' # ggplot2-based plots #' if (require("ggplot2")) { #' library(ggplot2) #' #' # Default plot uses bars and highlighting values larger than the mean #' ggbertinplot(x, order) #' #' # highlight values in the 4th quartile #' ggbertinplot(x, order, highlight = quantile(x, probs = .75)) #' #' # Use different geoms. "none" lets the user specify their own geom. #' # Variables set are row, col and x (for the value). #' #' ggbertinplot(x, order, geom = "tile", prop = TRUE) #' ggbertinplot(x, order, geom = "rectangle") #' ggbertinplot(x, order, geom = "rectangle", prop = TRUE) #' ggbertinplot(x, order, geom = "circle") #' ggbertinplot(x, order, geom = "line") #' #' # Tiles with diverging color scale #' ggbertinplot(x, order, geom = "tile", prop = TRUE) + #' scale_fill_gradient2(midpoint = mean(x)) #' #' # Custom geom (geom = "none"). Defined variables are row, col, and x for the value #' ggbertinplot(x, order, geom = "none", prop = FALSE) + #' geom_point(aes(x = col, y = row, size = x, color = x > 30), pch = 15) + #' scale_size(range = c(1, 10)) #' #' # Use a ggplot2 theme with theme_set() #' old_theme <- theme_set(theme_minimal() + #' theme(panel.grid = element_blank()) #' ) #' ggbertinplot(x, order, geom = "bar") #' theme_set(old_theme) #' } #' @export bertinplot <- function(x, order = NULL, panel.function = panel.bars, highlight = TRUE, row_labels = TRUE, col_labels = TRUE, flip_axes = TRUE, ...) { if (!is.matrix(x)) stop("Argument 'x' must be a matrix.") # add ... to options options <- list(...) options$panel.function <- panel.function options <- .get_parameters( options, list( panel.function = panel.bars, flip_axes = TRUE, frame = FALSE, spacing = 0.2, margins = c(5, 4, 8, 8), gp_labels = gpar(), gp_panels = gpar(), shading = NULL, shading_col = .sequential_pal(100), newpage = TRUE, pop = TRUE ) ) ## panel.blocks has no spacing! if (identical(options$panel.function, panel.blocks)) options$spacing <- 0 if (is.null(options$shading)) if (identical(options$panel.function, panel.blocks)) { options$shading <- TRUE } else { options$shading <- FALSE } ## order if (!is.null(order)) x <- permute(x, order) ## note: Bertin switched cols and rows for his display! # change x and y? if (flip_axes) x <- t(x) ## highlight if (is.logical(highlight) && highlight) highlight <- mean(x, na.rm = TRUE) ## clear page if (options$newpage) grid.newpage() ## create outer viewport xlim <- c(options$spacing, ncol(x) + 1 - options$spacing) pushViewport( plotViewport( margins = options$mar, layout = grid.layout(nrow(x), 1), xscale = xlim, yscale = c(0, nrow(x)), default.units = "native", name = "bertin" ) ) # shading and highlighting if (options$shading) col <- .map_color(x, options$shading_col) else col <- matrix(1, nrow = nrow(x), ncol = ncol(x)) if (highlight) col[x < highlight] <- NA # map to [0, 1] x <- map(x) for (variable in seq(nrow(x))) { value <- x[variable,] hl <- col[variable,] ## handle neg. values if (identical(options$panel.function, panel.bars) || identical(options$panel.function, panel.lines)) { ylim <- c(min(value, 0, na.rm = TRUE), max(value, 0, na.rm = TRUE) + options$spacing) } else{ ylim <- c(0, max(abs(value), 0.1, na.rm = TRUE)) } pushViewport( viewport( layout.pos.col = 1, layout.pos.row = variable, xscale = xlim, yscale = ylim, default.units = "native", gp = options$gp_panels ) ) ## call panel function options$panel.function(value, options$spacing, hl) ## do frame if (options$frame) grid.rect( x = seq(length(value)), width = 1, default.units = "native", gp = gpar(fill = NA) ) upViewport(1) } spacing_corr <- if (options$spacing <= 0) - options$spacing + 0.2 else 0 if (col_labels) grid.text( colnames(x), x = seq(ncol(x)), y = nrow(x) + spacing_corr, rot = 90, just = "left", default.units = "native", gp = options$gp_labels ) if (row_labels) grid.text( rev(rownames(x)), x = 1 + spacing_corr / ncol(x) / 4, y = 0.5:(nrow(x) - 0.5) / nrow(x), just = "left", default.units = "npc", gp = options$gp_labels ) if (options$pop) popViewport(1) else upViewport(1) } #' @rdname bertinplot #' @export panel.bars <- function(value, spacing, hl) { grid.rect( x = seq(length(value)), y = spacing / 2, width = 1 - spacing, height = value * (1 - spacing), just = c("centre", "bottom"), default.units = "native", gp = gpar(fill = hl) ) } #' @rdname bertinplot #' @export panel.circles <- function(value, spacing, hl) { ## neg. values are dashed lty <- as.integer(value < 0) + 1L lty[!is.finite(lty)] <- 0L value <- abs(value) value[value == 0] <- NA ### hide empty squares grid.circle( x = seq(length(value)), y = unit(.5, "npc"), r = value / 2 * (1 - spacing), default.units = "native", gp = gpar(fill = hl, lty = lty) ) } #' @rdname bertinplot #' @export panel.rectangles <- function(value, spacing, hl) { ## neg. values are dashed lty <- as.integer(value < 0) + 1L lty[!is.finite(lty)] <- 0L value[value == 0] <- NA ### hide emply squares grid.rect( x = seq(length(value)), width = value * (1 - spacing), height = value * (1 - spacing), default.units = "native", just = c("centre", "center"), gp = gpar(fill = hl, lty = lty) ) } #' @rdname bertinplot #' @export panel.squares <- panel.rectangles #' @rdname bertinplot #' @export panel.tiles <- function(value, spacing, hl) { grid.rect( x = seq(length(value)), width = 1, height = unit(1, "npc"), default.units = "native", just = c("centre", "center"), gp = gpar(fill = hl) ) } #' @rdname bertinplot #' @export panel.blocks <- panel.tiles ### hl is ignored #' @rdname bertinplot #' @export panel.lines <- function(value, spacing, hl) { grid.lines( x = seq(length(value)), y = value * (1 - spacing), default.units = "native" ) } ## add cut lines manually to a bertin plot #' @rdname bertinplot #' @export bertin_cut_line <- function(x = NULL, y = NULL, col = "red") { if (length(x) < 2) x <- rep(x, 2) if (length(y) < 2) y <- rep(y, 2) ## find the bertin Viewport if (inherits(try(seekViewport("bertin"), silent = TRUE) , "try-error")) { stop("bertinplot() needs to be called with options = list(pop = FALSE) first!") } if (is.null(x)) x <- unit(c(0, 1), units = "npc") else x <- x + .5 if (is.null(y)) y <- unit(c(0, 1), units = "npc") else y <- y grid.lines( x = x, y = y, default.units = "native", gp = gpar(col = col, lwd = 2) ) } seriation/R/Munsingen.R0000644000176200001440000000435414607604705014555 0ustar liggesusers#' Hodson's Munsingen Data Set #' #' This data set contains a grave times artifact incidence matrix for the #' Celtic Münsingen-Rain cemetery in Switzerland as provided by Hodson (1968) #' and published by Kendall 1971. #' #' @name Munsingen #' @docType data #' @family data #' @format A 59 x 70 0-1 matrix. Rows (graves) and columns (artifacts) are in #' the order determined by Hodson (1968). #' @references Hodson, F.R. (1968). #' _The La Tene Cemetery at Münsingen-Rain,_ Stämpfli, Bern. #' #' Kendall, D.G. (1971): Seriation from abundance matrices. In: Hodson, F.R., #' Kendall, D.G. and Tautu, P., (Editors), _Mathematics in the #' Archaeological and Historical Sciences,_ Edinburgh University Press, #' Edinburgh, 215--232. #' @keywords datasets #' @examples #' data("Munsingen") #' #' ## Seriation method after Kendall (1971) #' ## Kendall's square symmetric matrix S and SoS #' S <- function(x, w = 1) { #' sij <- function(i , j) w * sum(pmin(x[i,], x[j,])) #' h <- nrow(x) #' r <- matrix(ncol = h, nrow =h) #' for(i in 1:h) for (j in 1:h) r[i,j] <- sij(i,j) #' r #' } #' #' SoS <- function(x) S(S(x)) #' #' ## Kendall's horse shoe (Hamiltonian arc) #' horse_shoe_plot <- function(mds, sigma, threshold = mean(sigma), ...) { #' plot(mds, main = paste("Kendall's horse shoe with th =", threshold), ...) #' l <- which(sigma > threshold, arr.ind=TRUE) #' for(i in 1:nrow(l)) lines(rbind(mds[l[i,1],], mds[l[i,2],])) #' } #' #' ## shuffle data #' x <- Munsingen[sample(nrow(Munsingen)),] #' #' ## calculate matrix and do isoMDS (from package MASS) #' sigma <- SoS(x) #' library("MASS") #' mds <- isoMDS(1/(1+sigma))$points #' #' ## plot Kendall's horse shoe #' horse_shoe_plot(mds, sigma) #' #' ## find order using a TSP #' library("TSP") #' tour <- solve_TSP(insert_dummy(TSP(dist(mds)), label = "cut"), #' method = "2-opt", control = list(rep = 15)) #' tour <- cut_tour(tour, "cut") #' lines(mds[tour,], col = "red", lwd = 2) #' #' ## create and plot order #' order <- ser_permutation(tour, 1:ncol(x)) #' bertinplot(x, order, options= list(panel=panel.circles, #' rev = TRUE)) #' #' ## compare criterion values #' rbind( #' random = criterion(x), #' reordered = criterion(x, order), #' Hodson = criterion(Munsingen) #' ) NULL seriation/R/criterion.matrix.R0000644000176200001440000001025214607757550016114 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. #' @rdname criterion #' @export criterion.matrix <- function(x, order = NULL, method = NULL, force_loss = FALSE, ...) .criterion_array_helper(as.matrix(x), order, method, "matrix", force_loss) #' @rdname criterion #' @export criterion.data.frame <- criterion.matrix #' @rdname criterion #' @export criterion.table <- criterion.matrix ## Bond energy (BEA) criterion_ME <- function(x, order = NULL, ...) { # ... unused if (any(x < 0)) { warning("Bond energy (ME) is only defined for nonnegative matrices. Returning NA.") return(NA_real_) } n <- nrow(x) m <- ncol(x) if (!is.null(order)) x <- permute(x, order) mode(x) <- "single" ener <- 0.0 energy <- .Fortran( "energy", n = as.integer(n), m = as.integer(m), b = as.matrix(x), ener = as.single(ener), PACKAGE = "seriation" ) 0.5 * as.numeric(energy$ener) } ## the interface to the stress functions allows for ## arbitrary subsetting (see the wrapper in C). ## (C) ceeboo 2005, 2006 .stress <- function(x, order, type = "moore") { TYPE <- c(1, 2) names(TYPE) <- c("moore", "neumann") if (inherits(x, "dist")) x <- as.matrix(x) if (!is.matrix(x)) stop("Argument 'x' must be a matrix.") if (!is.double(x)) mode(x) <- "double" if (is.null(order)) { rows <- as.integer(1:dim(x)[1]) cols <- as.integer(1:dim(x)[2]) } else{ rows <- get_order(order, 1) cols <- get_order(order, 2) } type <- as.integer(TYPE[type]) x <- .Call("stress", x, rows, cols, type) ## does only half of the matrix! 2 * x } criterion_stress_moore <- function(x, order, ...) .stress(x, order, "moore") criterion_stress_neumann <- function(x, order, ...) .stress(x, order, "neumann") ### A MEASURE OF EFFECTIVENESS FOR THE MOMENT ORDERING ALGORITHM ### by Deutsch & Martin (1971) ### Correlation coefficient R for matrices. criterion_R_matrix <- function(x, order, ...) { if (!is.null(order)) x <- permute(x, order) M <- nrow(x) N <- ncol(x) ## total sum T <- sum(x) ## X_i = i/M; Y_j = j/N X_i <- (1:M) / M Y_j <- (1:N) / N ## X_bar = 1/T sum_i,j a_ij X_i X_bar <- 1 / T * sum(crossprod(x, X_i)) ## Y_bar = 1/T sum_i,j a_ij Y_j Y_bar <- 1 / T * sum(crossprod(t(x), Y_j)) ## S_X2 = 1/(T-1) sum_i,j a_ij (X_i - X_bar)^2 S_X2 <- 1 / (T - 1) * sum(crossprod(x, (X_i - X_bar) ^ 2)) ## S_Y2 = 1/(T-1) sum_i,j a_ij (Y_j - Y_bar)^2 S_Y2 <- 1 / (T - 1) * sum(crossprod(t(x), (Y_j - Y_bar) ^ 2)) ## S_XY = 1/(T-1) sum_i,j a_ij (X_i - X_bar) (Y_j - Y_bar) S_XY <- 1 / (T - 1) * sum(x * outer(X_i - X_bar, Y_j - Y_bar)) ## R = S_XY/(S_X S_Y) S_XY / (sqrt(S_X2) * sqrt(S_Y2)) } ## register built-ins set_criterion_method("matrix", "ME", criterion_ME, "Measure of effectiveness (McCormick, 1972).", TRUE) set_criterion_method("matrix", "Cor_R", criterion_R_matrix, "Weighted correlation coefficient R: A measure of effectiveness normalized between -1 and 1 (Deutsch and Martin, 1971).", TRUE) set_criterion_method( "matrix", "Moore_stress", criterion_stress_moore, "Stress criterion (Moore neighborhood) applied to the reordered matrix (Niermann, 2005).", FALSE ) set_criterion_method( "matrix", "Neumann_stress", criterion_stress_neumann, "Stress criterion (Neumann neighborhood) applied to the reordered matrix (Niermann, 2005).", FALSE ) seriation/R/seriate_Mean.R0000644000176200001440000000315014457043134015173 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. .seriate_mean_control <- list( transformation = NULL ) attr(.seriate_mean_control, "help") <- list( transformation = "transformation function applied before calculating means (e.g., scale)" ) seriate_matrix_mean <- function(x, control = NULL, margin = NULL) { control <- .get_parameters(control, .seriate_mean_control) if(!is.null(control$transformation)) x <- control$transformation(x) if (1L %in% margin) row <- order(rowMeans(x, na.rm = TRUE)) else row <- NA if (2L %in% margin) col <- order(colMeans(x, na.rm = TRUE)) else col <- NA list(row = row, col = col) } set_seriation_method( "matrix", "Mean", seriate_matrix_mean, "Reorders rows and columns by row and column means.", .seriate_mean_control ) seriation/R/ser_permutation_vector2matrix.R0000644000176200001440000000240714450055020020702 0ustar liggesusers#' Conversion Between Permutation Vector and Permutation Matrix #' #' Converts between permutation vectors and matrices. #' #' @family permutation #' #' @param x A permutation vector (any object that can be converted into a #' permutation vector, e.g., a integer vector or a `hclust` object) or a #' matrix representing a permutation. Arguments are checked. #' @returns #' - `permutation_vector2matrix()`: returns a permutation matrix. #' - `permutation_matrix2vector()`: returns the permutation as a integer vector. #' #' @author Michael Hahsler #' @keywords manip #' @examples #' ## create a random permutation vector #' pv <- structure(sample(5), names = paste0("X", 1:5)) #' pv #' #' ## convert into a permutation matrix #' pm <- permutation_vector2matrix(pv) #' pm #' #' ## convert back #' permutation_matrix2vector(pm) #' @export permutation_vector2matrix <- function(x) { x <- get_order(x) .valid_permutation_vector(x) n <- length(x) pm <- matrix(0, nrow = n, ncol = n) for (i in 1:n) pm[i, x[i]] <- 1 dimnames(pm) <- list(names(x), names(x)) pm } #' @rdname permutation_vector2matrix #' @export permutation_matrix2vector <- function(x) { .valid_permutation_matrix(x) o <- apply( x, MARGIN = 1, FUN = function(r) which(r == 1) ) o } seriation/R/seriate.matrix.R0000644000176200001440000000233314457362306015545 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. #' @rdname seriate #' @include seriate.dist.R #' @export seriate.matrix <- function(x, method = "PCA", control = NULL, margin = c(1L, 2L), rep = 1L, ...) { if (rep > 1L) return(seriate_rep(x, method, control, rep = rep, margin = margin, ...)) .seriate_array_helper(x, method, control, margin, datatype = "matrix", ...) } seriation/R/seriate_best.R0000644000176200001440000002345314607520062015255 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. #' Best Seriation #' #' Often the best seriation method for a particular dataset is not know and #' heuristics may produce unstable results. #' `seriate_best()` and `seriate_rep()` automatically try different seriation methods or #' rerun randomized methods several times to find the best and order #' given a criterion measure. `seriate_improve()` uses a local improvement strategy #' to imporve an existing solution. #' #' `seriate_rep()` rerun a randomized seriation methods to find the best solution #' given the criterion specified for the method in the registry. #' A specific criterion can also be specified. #' Non-stochastic methods are automatically only run once. #' #' `seriate_best()` runs a set of methods and returns the best result given a #' criterion. Stochastic methods are automatically randomly restarted several times. #' #' `seriate_improve()` improves a seriation order using simulated annealing using #' a specified criterion measure. It uses [seriate()] with method "`GSA`", #' a reduced probability to accept bad moves, and a lower minimum temperature. Control #' parameters for this method are accepted. #' #' **Criterion** #' #' If no criterion is specified, ten the criterion specified for the method in #' the registry (see `[get_seriation_method()]`) is used. For methods with no #' criterion in the registry (marked as "other"), a default method is used. #' The defaults are: #' #' * `dist`: `"AR_deviations"` - the study in Hahsler (2007) has shown that this #' criterion has high similarity with most other criteria. #' * `matrix`: "Moore_stress" #' #' **Parallel Execution** #' #' Some methods support for parallel execution is provided using the #' [foreach][foreach::foreach] package. To #' use parallel execution, a suitable backend needs to be registered (see #' the Examples section for using the [doParallel][doParallel::doParallel] backend). #' #' @family seriation #' #' @param x the data. #' @param method a character string with the name of the seriation method #' (default: varies by data type). #' @param methods a vector of character string with the name of the seriation #' methods to try. #' @param control a list of control options passed on to [seriate()]. #' For `seriate_best()` control needs to be a named list of control lists #' with the names matching the seriation methods. #' @param criterion `seriate_rep()` chooses the criterion specified for the #' method in the registry. A character string with the [criterion] to optimize #' can be specified. #' @param verbose logical; show progress and results for different methods #' @param rep number of times to repeat the randomized seriation algorithm. #' @param parallel logical; perform replications in parallel. #' Uses [foreach::foreach()] if a #' `%dopar%` backend (e.g., [doParallel::doParallel]) is registered. #' @param ... further arguments are passed on to the [seriate()]. #' #' @return Returns an object of class [ser_permutation]. #' #' @author Michael Hahsler #' #' @keywords optimize cluster #' @references #' Hahsler, M. (2017): An experimental comparison of seriation methods for #' one-mode two-way data. \emph{European Journal of Operational Research,} #' \bold{257}, 133--143. #' \doi{10.1016/j.ejor.2016.08.066} #' #' @examples #' data(SupremeCourt) #' d_supreme <- as.dist(SupremeCourt) #' #' # find best seriation order (tries by by default several fast methods) #' o <- seriate_best(d_supreme, criterion = "AR_events") #' o #' pimage(d_supreme, o) #' #' # run a randomized algorithms several times. It automatically chooses the #' # LS criterion. Repetition information is returned as attributes #' o <- seriate_rep(d_supreme, "QAP_LS", rep = 5) #' #' attr(o, "criterion") #' hist(attr(o, "criterion_distribution")) #' pimage(d_supreme, o) #' #' \dontrun{ #' # Using parallel execution on a larger dataset #' data(iris) #' m_iris <- as.matrix(iris[sample(seq(nrow(iris))),-5]) #' d_iris <- dist(m_iris) #' #' library(doParallel) #' registerDoParallel(cores = detectCores() - 1L) #' #' # seriate rows of the iris data set #' o <- seriate_best(d_iris, criterion = "LS") #' o #' #' pimage(d_iris, o) #' #' # improve the order to minimize RGAR instead of LS #' o_improved <- seriate_improve(d_iris, o, criterion = "RGAR") #' pimage(d_iris, o_improved) #' #' # available control parameters for seriate_improve() #' get_seriation_method(name = "GSA") #' } #' @export seriate_best <- function(x, methods = NULL, control = NULL, criterion = NULL, rep = 10L, parallel = TRUE, verbose = TRUE, ...) { ### data.frame/table? kind <- get_seriation_kind(x) # set some default methods if (is.null(methods)) { if (kind == "dist") { methods <- c( "spectral", ## 2-Sum "MDS", ## Moore stress "QAP_2SUM", "QAP_BAR", "QAP_LS", "QAP_Inertia", "TSP", ## path length "OLO_average" ## restricted path length ) } else if (kind == "matrix") methods <- c("BEA_TSP", "PCA", "Heatmap", "PCA_angle") else stop("Currently only seriation for dist and matrix are supported.") } if (is.null(criterion)) criterion <- get_default_criterion(x) criterion <- get_criterion_method(kind, criterion)$name if (verbose) { cat("Criterion:", criterion, "\n") cat("Performing: ") } os <- sapply( methods, FUN = function(m) { if (verbose) { cat("\n") cat(m, " - ") } #tm <- system.time(o <- seriate(x, m, ...)) tm <- system.time( o <- seriate_rep( x, m, control = control[[m]], verbose = verbose, criterion = criterion, rep = rep, parallel = parallel, ... ) ) attr(o, "time") <- tm[1] + tm[2] attr(o, "criterion") <- criterion(x, o, criterion, force_loss = TRUE) o }, simplify = FALSE ) if (verbose) { df <- data.frame( method = names(os), criterion = sapply(os, attr, "criterion"), secs = sapply(os, attr, "time"), row.names = NULL ) df <- df[order(df$criterion),] cat("\nResults (first was chosen):\n") print(df) cat("\n") } os[[which.min(sapply(os, attr, "criterion"))]] } #' @rdname seriate_best #' @importFrom foreach times `%dopar%` `%do%` #' @export seriate_rep <- function(x, method = NULL, control = NULL, criterion = NULL, rep = 10L, parallel = TRUE, verbose = TRUE, ...) { if (is.null(method)) method <- get_default_method(x) m <- get_seriation_method(get_seriation_kind(x), method) method <- m$name if (is.null(criterion)) criterion <- m$optimizes if (is.na(criterion)) criterion <- get_default_criterion(x) if (!m$randomized && rep > 1L) { rep <- 1L if (verbose) cat("Method not randomized. Running once") } if (verbose && rep > 1L) { cat("Tries", rep, " ") } #r <- replicate(rep, { if (verbose) cat("."); seriate(x, method, control) }, # simplify = FALSE) # r <- times(rep) %dopar% { list(seriate(x, method, control)) } dopar <- ifelse(foreach::getDoParRegistered() && parallel && rep > 1L, `%dopar%`, `%do%`) r <- dopar(times(rep), { if (verbose) cat(".") list(seriate(x, method, control, ...)) }) if (verbose) cat("\n") cs <- sapply( r, FUN = function(o) criterion(x, o, criterion, force_loss = TRUE) ) o <- r[[which.min(cs)]] attr(o, "criterion") <- min(cs) attr(o, "criterion_method") <- criterion attr(o, "criterion_distribution") <- as.vector(cs) if (verbose && rep > 1L) cat( "Found orders with", sQuote(criterion), "in the range" , min(cs), "to", max(cs), "- returning best\n" ) o } #' @rdname seriate_best #' @param order a `ser_permutation` object for `x` or the name of a seriation method to start with. #' @export seriate_improve <- function(x, order, criterion = NULL, control = NULL, verbose = TRUE, ...) { if (is.null(criterion)) criterion <- get_default_criterion(x) criterion <- get_criterion_method(get_seriation_kind(x), criterion)$name if (is.null(control)) control <- list() if (is.null(control$p_initial)) control$p_initial <- 0.01 * 1e-6 if (is.null(control$t_min)) control$t_min <- 1e-12 control$warmstart <- order control$criterion <- criterion control$verbose <- verbose seriate(x, "GSA", control = control, ...) } seriation/R/seriate_vegan.R0000644000176200001440000000652214457044335015425 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. .monoMDS_control <- structure({ l <- as.list(args(vegan::monoMDS)) l$k <- NULL l$model <- "global" tail(head(l,-2L),-1L) }, help = list(y = "See ? monoMDS for help")) seriate_dist_monoMDS <- function(x, control = NULL) { control <- .get_parameters(control, .monoMDS_control) r <- do.call(vegan::monoMDS, c(list(x, k = 1), control)) conf <- r$points if (control$verbose) { r$call <- NULL print(r) } structure(order(conf), configutation = conf) } set_seriation_method( "dist", "monoMDS", seriate_dist_monoMDS, "Kruskal's (1964a,b) non-metric multidimensional scaling (NMDS) using monotone regression.", control = .monoMDS_control, randomized = TRUE, optimizes = .opt("MDS_stress", "Kruskal's monotone regression stress") ) .isomap_control <- structure( list(k = 30, path = "shortest"), help = list(k = "number of shortest dissimilarities retained for a point", path = "method used in to estimate the shortest path (\"shortest\"/\"extended\")") ) seriate_dist_isomap <- function(x, control = NULL) { control <- .get_parameters(control, .isomap_control) r <- do.call(vegan::isomap, c(list(x, ndim = 1), control)) conf <- r$points if (control$verbose) { r$call <- NULL print(r) } structure(order(conf), configutation = conf) } set_seriation_method( "dist", "isomap", seriate_dist_isomap, "Isometric feature mapping ordination", control = .isomap_control, optimizes = .opt(NA, "Stress on shortest path distances") ) .metaMDS_control <- structure({ l <- as.list(args(vegan::metaMDS)) l <- tail(head(l, -2L), -1L) l$k <- NULL l$engine <- "monoMDS" l$noshare <- FALSE #l$distance = "euclidean" l$trace <- 0 l$verbose <- FALSE l }, help = list(distance = "see ? metaMDS for help") ) seriate_dist_metaMDS <- function(x, control = NULL) { control <- .get_parameters(control, .metaMDS_control) r <- do.call(vegan::metaMDS, c(list(x, k = 1), control)) conf <- r$points if(control$verbose && control$trace == 0) control$trace <- 1 if (control$verbose) { r$call <- NULL r$data <- NULL print(r) } structure(order(conf), configutation = conf) } set_seriation_method( "dist", "metaMDS", seriate_dist_metaMDS, "Nonmetric Multidimensional Scaling with Stable Solution from Random Starts.", control = .metaMDS_control, randomized = FALSE, ### it is randomized, but internally does replication optimizes = .opt("MDS_stress", "Kruskal's monotone regression stress") ) seriation/R/uniscale.R0000644000176200001440000002056714610027554014414 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2017 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. #' Fit an Unidimensional Scaling for a Seriation Order #' #' Fits an (approximate) unidimensional scaling configuration given an order. #' #' This implementation uses the method describes in Maier and De Leeuw (2015) to calculate the #' minimum stress configuration for a given (seriation) order by performing a 1D MDS fit. #' If the 1D MDS fit does not preserve the given order perfectly, then a warning is #' produced indicating #' for how many positions order could not be preserved. #' The seriation method which is consistent to uniscale is `"MDS_smacof"` #' which needs to be registered with [`register_smacof()`]. #' #' #' The code is similar to `smacof::uniscale()` (de Leeuw, 2090), #' but scales to larger #' datasets since it only uses the permutation given by `order`. #' #' `MDS_stress()` calculates the normalized stress of a configuration given by a seriation order. #' If the order does not contain a configuration, then a minimum-stress configuration if calculates #' for the given order. #' #' All distances are first normalized to an average distance of close to 1 using #' \eqn{d_{ij} \frac{\sqrt{n(n-1)/2}}{\sqrt{\sum_{i 0 && warn) { warning("Configutation order does not preserve given order! Mismatches: ", mismatches, " of ", n, " - returning initial configuration instead.") } if (!accept_reorder && mismatches > 0) t <- init_config #cat("init:\n") #print(names(init_config)) #cat("d:\n") #print(labels(d)) names(t) <- labels(d) t } # normalize the distances to roughly n*(n-1) / 2 so the average distance # is close to 1 .normDiss <- function (diss) diss / sqrt(sum(diss ^ 2, na.rm = TRUE)) * sqrt(length(diss)) #' @rdname uniscale #' @param refit logical; forces to refit a minimum-stress MDS configuration, #' even if `order` contains a configuration. #' @export MDS_stress <- function(d, order, refit = TRUE, warn = FALSE) { d <- as.dist(d) o <- ser_permutation(order) emb <- get_config(o) if(is.null(emb) || refit) emb <- uniscale(d, o, warn = warn) d_emb <- dist(emb) d_emb <- .normDiss(d_emb) d <- .normDiss(d) sqrt(sum((d - d_emb)^2) / sum(d_emb^2)) } .smacof_contr <- structure( list( warn = FALSE ), help = list( warn = "produce a warning if the 1D MDS fit does not preserve the given order (see ? seriation::uniscale)." ) ) set_criterion_method( "dist", "MDS_stress", MDS_stress, "Normalized stress of a configuration given by a seriation order", FALSE, control = .smacof_contr ) #' @rdname uniscale #' @param dim The dimension if `x` is a `ser_permutation` object. #' @export get_config <- function(x, dim = 1L, ...) { if (inherits(x, "ser_permutation")) x <- x[[dim]] if (inherits(x, "ser_permutation_vector")) x <- attr(x, "configuration") if(is.null(x)) return(NULL) if (!(is.numeric(x) && ((is.vector(x) || is.matrix(x))))) stop("Unable to get configuration. Supply a ser_permutation.") x } #' @rdname uniscale #' @param x a scaling returned by `uniscale()` or a #' `ser_permutation` with a configuration attribute. #' @param main main plot label #' @param pch print character #' @param labels add the object names to the plot #' @param pos label position for 2D plot (see [text()]). #' @param cex label expansion factor. #' @export plot_config <- function (x, main, pch = 19, labels = TRUE, pos = 1, cex = 1, ...) { if (missing(main)) main <- "Configuration" o <- get_order(x) x <- get_config(x) if (is.null(x)) stop( "Permutation vector has no configuration attribute. Use uniscale() first to calcualte a configuration" ) # 2D if (is.matrix(x)) { graphics::plot(x, pch = pch, main = main, ...) if (labels) graphics::text(x = x, labels = rownames(x), pos = pos, cex = cex) graphics::lines(x[get_order(o), , drop = FALSE], col = "grey") } else{ # 1D x <- drop(x) n <- length(x) plot( x, rep(0, n), axes = FALSE, ann = FALSE, pch = pch, type = "o", ylim = c(-0.2, 0.8), ... ) title(main) labs <- names(x) if (is.null(labs)) labs <- 1:n if (labels) text(x, rep(0, n) + 0.05, labs, srt = 90, cex = cex, adj = c(0, 0.5)) } } seriation/R/AAA_parameters.R0000644000176200001440000000353514456356241015420 0ustar liggesusers####################################################################### # Code to check parameter/control objects # Copyright (C) 2011 Michael Hahsler # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ## helper to parse parameter lists with defaults .nodots <- function(...) { l <- list(...) if (length(l) > 0L) warning("Unknown arguments: ", paste(names(l), "=", l, collapse = ", ")) } .get_parameters <- function(parameter, defaults) { defaults <- as.list(defaults) parameter <- as.list(parameter) ## add verbose if (is.null(defaults$verbose)) defaults$verbose <- FALSE o <- integer() if (length(parameter) != 0) { o <- pmatch(names(parameter), names(defaults)) ## unknown parameter if (any(is.na(o))) { warning(sprintf( "%s: Unknown control parameter(s) %s are ignored. Rerun with verbose = TRUE.", deparse(sys.calls()[[sys.nframe()-3]]), paste(sQuote(names(parameter)[is.na(o)]), collapse = ", ") ), call. = FALSE) } ### defaults are now the actual parameters defaults[o[!is.na(o)]] <- parameter[!is.na(o)] } if (defaults$verbose) { cat("control:\n") .print_control(defaults, "used values") } defaults } seriation/R/register_optics.R0000644000176200001440000000504614607606161016014 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2015 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. #' Register Seriation Based on OPTICS #' #' Use ordering points to identify the clustering structure (OPTICS) for [seriate()]. #' #' Registers the method `"optics"` for [seriate()]. This method applies #' the OPTICS ordering algorithm implemented in [`dbscan::optics()`] to create an ordering. #' #' **Note:** Package \pkg{dbscan} needs to be installed. #' #' @aliases register_optics optics OPTICS #' @seealso [dbscan::optics()]. #' @family seriation #' @returns Nothing. #' #' @references Mihael Ankerst, Markus M. Breunig, Hans-Peter Kriegel, Joerg #' Sander (1999). OPTICS: Ordering Points To Identify the Clustering Structure. #' _ACM SIGMOD international conference on Management of data,_ ACM Press, pp. #' 49-60. \doi{10.1145/304181.304187} #' @keywords optimize cluster #' @examples #' #' \dontrun{ #' register_optics() #' get_seriation_method("dist", "optics") #' #' d <- dist(random.robinson(50, pre=TRUE, noise=.1)) #' #' o <- seriate(d, method = "optics") #' pimage(d, o) #' } #' #' @export register_optics <- function() { check_installed("dbscan") .contr <- structure( list(eps = NULL, minPts = 5), help = list(eps = "upper limit of the size of the epsilon neighborhood (see ? optics)" , minPts = "minimum density for dense neighborhoods") ) optics_order <- function(x, control) { control <- .get_parameters(control, .contr) control$minPts <- min(control$minPts, attr(x, "Size")) dbscan::optics(x, eps = control$eps, minPts = control$minPts)$order } set_seriation_method( "dist", "optics", optics_order, "Use ordering points to identify the clustering structure (OPTICS) to create an order", .contr, verbose = TRUE ) } seriation/R/register_tsne.R0000644000176200001440000001421114607573451015463 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2015 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. #' Register Seriation Based on 1D t-SNE #' #' Use t-distributed stochastic neighbor embedding (t-SNE) for [seriate()]. #' #' Registers the method `"tsne"` for [seriate()]. This method applies #' 1D t-SNE to a data matrix or a distance matrix and extracts the order #' from the 1D embedding. To speed up the process, an initial embedding is #' created using 1D multi-dimensional scaling (MDS) or principal #' comonents analysis (PCA) which is improved by t-SNE. #' #' The `control` parameter `"mds"` or `"pca"` controls if MDS (for distances) #' or PCA (for data matrices) is used to create an #' initial embedding. See [Rtsne::Rtsne()] to learn about the other #' available `control` parameters. #' #' Perplexity is automatically set as the minimum between 30 and the number of #' observations. It can be also specified using the control parameter #' `"preplexity"`. #' #' **Note:** Package \pkg{Rtsne} needs to be installed. #' #' @aliases register_tsne tsne tSNE #' @seealso [Rtsne::Rtsne()] #' @family seriation #' @returns Nothing. #' #' @references van der Maaten, L.J.P. & Hinton, G.E., 2008. Visualizing #' High-Dimensional Data Using t-SNE. _Journal of Machine Learning Research,_ #' **9**, #' pp.2579-2605. #' @keywords optimize cluster #' @examples #' #' \dontrun{ #' register_tsne() #' #' # distances #' get_seriation_method("dist", "tsne") #' #' data(SupremeCourt) #' d <- as.dist(SupremeCourt) #' #' o <- seriate(d, method = "tsne", verbose = TRUE) #' pimage(d, o) #' #' # look at the returned configuration and plot it #' attr(o[[1]], "configuration") #' plot_config(o) #' #' # the t-SNE results are also available as an attribute (see ? Rtsne::Rtsne) #' attr(o[[1]], "model") #' #' ## matrix #' get_seriation_method("matrix", "tsne") #' #' data("Zoo") #' x <- Zoo #' #' x[,"legs"] <- (x[,"legs"] > 0) #' #' # t-SNE does not allow duplicates #' x <- x[!duplicated(x), , drop = FALSE] #' #' class <- x$class #' label <- rownames(x) #' x <- as.matrix(x[,-17]) #' #' o <- seriate(x, method = "tsne", eta = 10, verbose = TRUE) #' pimage(x, o, prop = FALSE, row_labels = TRUE, col_labels = TRUE) #' #' # look at the row embedding #' plot_config(o[[1]], col = class) #' } #' #' @export register_tsne <- function() { check_installed("Rtsne") .contr <- structure( list( max_iter = 1000, theta = 0.5, perplexity = NULL, eta = 100, mds = TRUE, verbose = FALSE ), help = list( max_iter = "number of iterations", theta = "speed/accuracy trade-off (increase for less accuracy)", perplexity = "perplexity parameter (calculated as n - 1 / 3)", eta = "learning rate", mds = "start from a classical MDS solution" ) ) tsne_order <- function(x, control) { control <- .get_parameters(control, .contr) # start with MDS if (control$mds) Y_init <- stats::cmdscale(x, k = 1) else Y_init <- NULL # default is 30 (reduced for low n) if (is.null(control$preplexity)) control$perplexity <- 30 control$perplexity <- max(min(control$perplexity, floor(attr(x, "Size") / 3) - 1), 1) embedding <- Rtsne::Rtsne( x, dims = 1, is_distance = TRUE, max_iter = control$max_iter, theta = control$theta, eta = control$eta, perplexity = control$perplexity, Y_init = Y_init, verbose = control$verbose ) o <- order(embedding$Y) attr(o, "configuration") <- structure(drop(embedding$Y), names = attr(x, "Labels")) attr(o, "model") <- embedding o } .contr_matrix <- structure( list( max_iter = 1000, theta = 0.5, perplexity = NULL, eta = 100, pca = TRUE ), help = list(max_iter = "number of iterations", theta = "speed/accuracy trade-off (increase for less accuracy)", perplexity = "perplexity parameter (calculated as n - 1 / 3)", eta = "learning rate", pca = "start the PCA solution" )) tsne_order_matrix <- function(x, control) { control <- .get_parameters(control, .contr_matrix) # default is 30 (reduced for low n) if (is.null(control$preplexity)) control$perplexity <- 30 control$perplexity <- max(min(control$perplexity, floor(nrow(x) / 3) - 1), 1) embedding <- Rtsne::Rtsne( x, dims = 1, is_distance = FALSE, pca = control$pca, max_iter = control$max_iter, theta = control$theta, eta = control$eta, perplexity = control$perplexity, verbose = control$verbose ) o <- order(embedding$Y) attr(o, "configuration") <- structure(drop(embedding$Y), names = rownames(x)) attr(o, "model") <- embedding o } tsne_order_matrix_2 <- function(x, control, margin = seq_along(dim(x))) { if (1L %in% margin) row <- tsne_order_matrix(x, control) else row <- NA if (2L %in% margin) col <- tsne_order_matrix(t(x), control) else col <- NA list(row, col) } set_seriation_method( "dist", "tsne", tsne_order, "Use 1D t-distributed stochastic neighbor embedding (t-SNE) a distance matrix to create an order.", .contr, randomized = TRUE, verbose = TRUE ) set_seriation_method( "matrix", "tsne", tsne_order_matrix_2, "Use 1D t-distributed stochastic neighbor embedding (t-SNE) of the rows of a matrix to create an order.", .contr_matrix, randomized = TRUE, verbose = TRUE ) } seriation/R/seriate.table.R0000644000176200001440000000203214440636146015322 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. #' @rdname seriate #' @export seriate.table <- function(x, method = "CA", control = NULL, margin = c(1L, 2L), ...) seriate.matrix(x, method, control, margin, ...) seriation/R/gghmap.R0000644000176200001440000000275314313070703014043 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. #' @rdname hmap #' @include hmap.R #' @export gghmap <- function(x, distfun = stats::dist, method = "OLO", control = NULL, scale = c("none", "row", "column"), prop = FALSE, ...) { scale <- match.arg(scale) if (inherits(x, "dist")) { # scale and distFun are ignored! o <- seriate(x, method = method, control = control) } else { x <- as.matrix(x) contr <- list( dist_fun = distfun, seriation_method = method, seriation_control = control, scale = scale ) o <- seriate(x, method = "heatmap", control = contr) } ggpimage(x, o, prop = prop, ...) } seriation/R/seriate_identity.R0000644000176200001440000000351514440720023016140 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. seriate_dist_identity <- function(x, control = NULL) { #param <- .get_parameters(control, NULL) .get_parameters(control, NULL) o <- 1:attr(x, "Size") o } seriate_matrix_identity <- function(x, control, margin = seq_along(dim(x))) { control <- .get_parameters(control, NULL) lapply(seq_along(dim(x)), function(i) if (i %in% margin) seq(dim(x)[i]) else NA) } set_seriation_method("matrix", "Identity", seriate_matrix_identity, "Identity permutation", optimized = "None") set_seriation_method("array", "Identity", seriate_matrix_identity, "Identity permutation", optimized = "None") set_seriation_method("dist", "Identity", seriate_dist_identity, "Identity permutation", optimized = "None") seriation/R/AAA_registry_seriate.R0000644000176200001440000002454414607520701016634 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. #' Registry for Seriation Methods #' #' A registry to manage methods used by [seriate()]. #' #' The functions below are convenience function for the registry #' \code{registry_seriate}. #' #' \code{list_seriation_method()} lists all available methods for a given data #' type (\code{kind}) (e.g., "dist", "matrix"). #' The result is a vector of character strings with the #' method names that can be used in function `seriate()`. #' If \code{kind} is missing, then a list of #' methods is returned. #' #' \code{get_seriation_method()} returns detailed information for a given method in #' form of an object of class \code{"seriation_method"}. #' The information includes a description, parameters and the #' implementing function. #' #' With \code{set_seriation_method()} new seriation methods can be added by the #' user. The implementing function (\code{definition}) needs to have the formal #' arguments \code{x, control} and, for arrays and matrices \code{margin}, #' where \code{x} is the data object and #' \code{control} contains a list with additional information for the method #' passed on from \code{seriate()}, and \code{margin} is a vector specifying #' what dimensions should be seriated. #' The implementation has to return a list of #' objects which can be coerced into \code{ser_permutation_vector} objects #' (e.g., integer vectors). The elements in the list have to be in #' corresponding order to the dimensions of \code{x}. #' #' @import registry #' @name registry_for_seriaiton_methods #' @family seriation #' #' @param kind the data type the method works on. For example, \code{"dist"}, #' \code{"matrix"} or \code{"array"}. If missing, then methods for any type are #' shown. #' @param name the name for the method used to refer to the method in #' [seriate()]. #' @param names_only logical; return only the method name. `FALSE` returns #' also the method descriptions. #' @param definition a function containing the method's code. #' @param description a description of the method. For example, a long name. #' @param control a list with control arguments and default values. #' @param randomized logical; does the algorithm use randomization and re-running #' the algorithm several times will lead to different results (see: [seriate_rep()]). #' @param optimizes what criterion does the algorithm try to optimize #' (see: [list_criterion_methods()]). #' @param x an object of class "seriation_method" to be printed. #' @param verbose logical; print a message when a new method is registered. #' @param ... further information that is stored for the method in the #' registry. #' @returns #' - \code{list_seriation_method()} result is a vector of character strings with the #' names of the methods. These names are used for methods in `seriate()`. #' - \code{get_seriation_method()} returns a given method in form of an object of class #' \code{"seriation_method"}. #' #' @author Michael Hahsler #' @seealso This registry uses [registry::registry]. #' @keywords misc #' @examples #' # Registry #' registry_seriate #' #' # List all seriation methods by type #' list_seriation_methods() #' #' # List methods for matrix seriation #' list_seriation_methods("matrix") #' #' get_seriation_method(name = "BEA") #' #' # Example for defining a new seriation method (reverse identity function for matrix) #' #' # 1. Create the seriation method #' # (with margin since it is for arrays; NA means no seriation is applied) #' seriation_method_reverse <- function(x, control = NULL, #' margin = seq_along(dim(x))) { #' lapply(seq_along(dim(x)), function(i) #' if (i %in% margin) rev(seq(dim(x)[i])) #' else NA) #'} #' #' # 2. Register new method #' set_seriation_method("matrix", "Reverse", seriation_method_reverse, #' description = "Reverse identity order", control = list()) #' #' list_seriation_methods("matrix") #' get_seriation_method("matrix", "reverse") #' #' # 3. Use the new seriation methods #' seriate(matrix(1:12, ncol=3), "reverse") #' @export registry_seriate <- registry(registry_class = "seriation_registry", entry_class = "seriation_method") registry_seriate$set_field("kind", type = "character", is_key = TRUE, index_FUN = match_partial_ignorecase) registry_seriate$set_field("name", type = "character", is_key = TRUE, index_FUN = match_partial_ignorecase) registry_seriate$set_field("fun", type = "function", is_key = FALSE) registry_seriate$set_field("description", type = "character", is_key = FALSE) registry_seriate$set_field("control", type = "list", is_key = FALSE) registry_seriate$set_field("randomized", type = "logical", is_key = FALSE) registry_seriate$set_field("optimizes", type = "character", is_key = FALSE) #' @rdname registry_for_seriaiton_methods #' @export list_seriation_methods <- function(kind, names_only = TRUE) { if (missing(kind)) { kinds <- unique(sort(as.vector( sapply(registry_seriate$get_entries(), "[[", "kind") ))) sapply( kinds, FUN = function(k) list_seriation_methods(k, names_only = names_only) ) } else{ if (names_only) sort(as.vector(sapply( registry_seriate$get_entries(kind = kind), "[[", "name" ))) else { l <- registry_seriate$get_entries(kind = kind) l[order(names(l))] } } } #' @rdname registry_for_seriaiton_methods #' @export get_seriation_method <- function(kind, name) { ## catch deprecated methods if (tolower(name) == "mds_nonmetric") { name <- "isoMDS" warning("seriation method 'MDS_nonmetric' is now deprecated and will be removed in future releases. Using `isoMDS`") } if (tolower(name) == "mds_metric") { name <- "MDS" warning("seriation method 'MDS_metric' is now deprecated and will be removed in future releases. Using `MDS`") } if (missing(kind)) { method <- registry_seriate$get_entry(name = name) kind <- NA } else method <- registry_seriate$get_entry(kind = kind, name = name) if (is.null(method)) stop( "Unknown seriation method ", name, " for data type ", kind, ". Maybe the method has not been registered yet. ", "Check list_seriation_methods()." ) method } #' @rdname registry_for_seriaiton_methods #' @export set_seriation_method <- function(kind, name, definition, description = NULL, control = list(), randomized = FALSE, optimizes = NA_character_, verbose = FALSE, ...) { ## check formals if (!identical(names(formals(definition)), c("x", "control")) && !identical(names(formals(definition)), c("x", "control", "margin"))) stop("Seriation methods must have formals 'x', 'control' and optionally 'margin'.") ## check if entry already exists r <- registry_seriate$get_entry(kind = kind, name = name) if (!is.null(r) && r$name == name) { # warning( # "Entry with name \"", # name, # "\" for kind \"", # kind, # "\" already exists! Modifying entry." # ) registry_seriate$modify_entry( name = name, kind = kind, fun = definition, description = description, control = control, randomized = randomized, optimizes = optimizes ) } else { registry_seriate$set_entry( name = name, kind = kind, fun = definition, description = description, control = control, randomized = randomized, optimizes = optimizes ) } if (verbose) message("Registering new seriation method ", sQuote(name), " for ", sQuote(kind)) } #' @rdname registry_for_seriaiton_methods #' @export print.seriation_method <- function(x, ...) { if (is.na(x$optimizes)) opt <- "Other" else opt <- x$optimizes if (!is.null(attr(x$optimizes, "description"))) opt <- paste0(opt, " (", attr(x$optimizes, "description"), ")") writeLines(c( gettextf("name: %s", x$name), gettextf("kind: %s", x$kind), strwrap( gettextf("description: %s", x$description), prefix = " ", initial = "" ), gettextf("optimizes: %s", opt), gettextf("randomized: %s", x$randomized) )) writeLines("control:") .print_control(x$control) invisible(x) } .print_control <- function(control, label = "default values", help = TRUE, trim_values = 30L) { if (length(control) < 1L) { writeLines("no parameters") } else{ contr <- lapply( control, FUN = function(x) strtrim(paste(deparse(x), collapse = ""), trim_values) ) contr <- as.data.frame(t(as.data.frame(contr))) colnames(contr) <- c(label) contr <- cbind(contr, help = "N/A") if (!is.null(attr(control, "help"))) for (i in seq(nrow(contr))) { hlp <- attr(control, "help")[[rownames(contr)[i]]] if (!is.null(hlp)) contr[["help"]][i] <- hlp } print(contr, quote = FALSE) } cat("\n") } .opt <- function(criterion, description = NULL) structure(criterion, description = description) seriation/R/ser_permutation_vector.R0000644000176200001440000001655314456263461017422 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ## ser_permutation_vector represents a single permutation represented as an ## integer vector or a hclust object. ## Constructor ## x can be ## * an integer vector ## * a hclust or dendrogram object (leaf order) ## * NA represents the identity permutation ## * a ser_permutation (list) of length 1 #' Class ser_permutation_vector -- A Single Permutation Vector for Seriation #' #' The class `ser_permutation_vector` #' represents a single permutation vector. #' #' A permutation vector #' maps a set of \eqn{n} objects \eqn{\{O_1, O_2, ..., O_n\}}{{O_1, O_2, ..., O_n}} onto itself. #' #' __Ordering Representation:__ #' In \pkg{seriation} we represent a permutation \eqn{\pi}{\pi} #' as a vector which lists the objects' indices in their permuted order. This can #' be seen as replacing the object in position \eqn{i} with the object #' in position \eqn{\pi(i)}. #' For example, the permutation vector \eqn{\langle3, 1, 2\rangle}{<3, 1, 2>} indicates that in #' first position is the object with index 3 then the object with index 1 and finally #' the object with index 2. This representation is often called a (re)arrangement or ordering. #' The ordering can be extracted from a permutation vector object #' via [get_order()]. Such an ordering can be directly used #' to subset the list of original objects with `"["` to apply the permutation. #' #' __Rank Representation:__ #' An alternative way to specify a permutation is via a list of the ranks #' of the objects after permutation. This representation is often called #' a map or substitution. Ranks can be extracted from a permutation vector using [get_rank()]. #' #' __Permutation Matrix:__ #' Another popular representation is a permutation matrix which performs #' permutations using matrix multiplication. A permutation matrix can be obtained #' using [get_permutation_matrix()]. #' #' `ser_permutation_vector` objects are usually packed into #' a [ser_permutation] object #' which is a collection (a `list`) of \eqn{k} permutation vectors for \eqn{k}-mode data. #' #' The constructor `ser_permutation_vector()` #' checks if the permutation vector is valid #' (i.e. if all integers occur exactly once). #' #' @family permutation #' #' @param x,object an object if class `ser_permutation_vector`. #' Options for the constructor are: #' (1) an integer permutation vector, #' (2) an object of class [hclust], #' (3) a numeric vector with a MDS configuration, or #' (4) `NA` to indicate a identity permutation. #' @param method a string representing the method used to obtain the #' permutation vector. #' @param ... further arguments. #' #' @returns The constructor `ser_permutation_vector()` returns an #' object a `ser_permutation_vector` #' @author Michael Hahsler #' #' @examples #' o <- structure(sample(10), names = paste0("X", 1:10)) #' o #' #' p <- ser_permutation_vector(o, "random") #' p #' #' ## some methods #' length(p) #' get_method(p) #' get_order(p) #' get_rank(p) #' get_permutation_matrix(p) #' #' r <- rev(p) #' r #' get_order(r) #' #' ## create a symbolic identity permutation vector (with unknown length) #' ## Note: This can be used to permute an object, but methods #' ## like length and get_order are not available. #' ip <- ser_permutation_vector(NA) #' ip #' @keywords classes #' @export ser_permutation_vector <- function(x, method = NULL) { if (inherits(x, "ser_permutation_vector")) return(x) if (inherits(x, "hclust") || inherits(x, "dendrogram")) { # nothing to do } else if (length(x) == 1 && is.na(x)) { x <- NA_integer_ attr(x, "method") <- "identity permutation" } else if (is.integer(x)) { # permutation vector # do nothing } else if (is.numeric(x)) { # a configuration ats <- attributes(x) ### preserve attributes nm <- names(x) x <- order(x) attributes(x) <- ats names(x) <- nm } else if (inherits(x, "ser_permutation") && length(x) == 1) { x <- x[[1]] } else { stop("x does not contain a supported permutation.") } if (!is.null(method)) attr(x, "method") <- method class(x) <- c("ser_permutation_vector", class(x)) .valid_permutation_vector(x) x } #' @rdname ser_permutation_vector #' @param recursive ignored #' @export c.ser_permutation_vector <- function(..., recursive = FALSE) do.call("ser_permutation", list(...)) ## reverse #' @rdname ser_permutation_vector #' @export rev.ser_permutation_vector <- function(x) { if (inherits(x, "hclust")) { ser_permutation_vector(stats::as.hclust(rev(stats::as.dendrogram(x))), method = get_method(x)) } else ser_permutation_vector(rev(get_order(x)), method = get_method(x)) } #' @rdname ser_permutation_vector #' @param printable a logical; prints "unknown" instead of `NULL` for non-existing methods. #' @export get_method <- function(x, printable = FALSE) { method <- attr(x, "method") if (printable && is.null(method)) method <- "unknown" method } ## print et al #' @rdname ser_permutation_vector #' @export length.ser_permutation_vector <- function(x) { if (!.is_identity_permutation(x)) length(get_order(x)) else 0L } #' @rdname ser_permutation_vector #' @export print.ser_permutation_vector <- function(x, ...) { writeLines(c( gettextf("object of class %s", paste(sQuote(class( x )), collapse = ", ")), gettextf("contains a permutation vector of length %d", length(x)), gettextf("used seriation method: '%s'", get_method(x, printable = TRUE)) )) invisible(x) } ## fake summary (we don't really provide a summary, ## but summary produces now a reasonable result --- same as print) #' @rdname ser_permutation_vector #' @export summary.ser_permutation_vector <- function(object, ...) { object } ## helpers ## an identity permutation is a single NA. .is_identity_permutation <- function(x) is.na(x[1]) ## calls stop if the vector is not valid .valid_permutation_vector <- function(x) { ## identity vector is always valid if (.is_identity_permutation(x)) return(invisible(TRUE)) ## valid permutations have a get_order function implemented perm <- get_order(x) valid <- TRUE tab <- table(perm) if (any(tab != 1)) valid <- FALSE if (length(tab) != length(perm) || any(names(tab) != sequence(length(perm)))) valid <- FALSE if (!valid) stop("Invalid permutation vector!\nVector: ", paste(perm, collapse = ", ")) invisible(valid) } .valid_permutation_matrix <- function(x) { if (any(rowSums(x) != 1) || any(colSums(x) != 1) || any(x != 1 & x != 0)) stop("Not a valid permutation matrix") invisible(TRUE) } seriation/R/permute.R0000644000176200001440000002626314456363025014275 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. # helper ndim <- function(x) length(dim(x)) find_order <- function(x, order, ...) { if (is.logical(order)) { if(order) order <- seriate(x, ...) else order <- seriate(x, method = "identity", ...) } if (is.character(order)) order <- seriate(x, method = order, ...) if (!inherits(order, "ser_permutation")) order <- ser_permutation(order) # for debugging #print(order) order } #' Permute the Order in Various Objects #' #' Provides the generic function and methods for permuting the order of various #' objects including vectors, lists, dendrograms (also \code{hclust} objects), #' the order of observations in a \code{dist} object, the rows and columns of a #' matrix or data.frame, and all dimensions of an array given a suitable #' [ser_permutation] object. #' #' The permutation vectors in [ser_permutation] are suitable if the number #' of permutation vectors matches the number of dimensions of \code{x} and if #' the length of each permutation vector has the same length as the #' corresponding dimension of \code{x}. #' #' For 1-dimensional/1-mode data (list, vector, \code{dist}), \code{order} can #' also be a single permutation vector of class [ser_permutation_vector] #' or data which can be automatically coerced to this class (e.g. a numeric #' vector). #' #' For \code{dendrogram} and \code{hclust}, subtrees are rotated to represent #' the order best possible. If the order is not achieved perfectly then the #' user is warned. See also [reorder.hclust()] for #' reordering `hclust` objects. #' #' @family permutation #' #' @param x an object (a list, a vector, a \code{dist} object, a matrix, an #' array or any other object which provides \code{dim} and standard subsetting #' with \code{"["}). #' @param order an object of class [ser_permutation] which contains #' suitable permutation vectors for \code{x}. Alternatively, a character string with the #' name of a seriation method appropriate for `x` can be specified (see [seriate()]). #' This will perform seriation and permute `x`. The value `TRUE` will permute using the #' default seriation method. #' @param margin specifies the dimensions to be permuted as a vector with dimension indices. #' If `NULL`, \code{order} needs to contain a permutation for all dimensions. #' If a single margin is specified, then \code{order} can also contain #' a single permutation vector. #' \code{margin} are ignored. #' @param dist the distance matrix used to create the dendrogram. Only needed if #' order is the name of a seriation method. #' @param ... if `order` is the name of a seriation method, then additional arguments are #' passed on to [seriate()]. #' @returns A permuted object of the same class as `x`. #' @author Michael Hahsler #' @keywords manip #' @examples #' # List data types for permute #' methods("permute") #' #' # Permute matrix #' m <- matrix(rnorm(10), 5, 2, dimnames = list(1:5, LETTERS[1:2])) #' m #' #' # Permute rows and columns #' o <- ser_permutation(5:1, 2:1) #' o #' #' permute(m, o) #' #' ## permute only columns #' permute(m, o, margin = 2) #' #' ## permute using PCA seriation #' permute(m, "PCA") #' #' ## permute only rows using PCA #' permute(m, "PCA", margin = 1) #' #' # Permute data.frames using heatmap seration (= hierarchical #' # clustering + optimal leaf ordering) #' df <- as.data.frame(m) #' permute(df, "Heatmap") #' #' # Permute objects in a dist object #' d <- dist(m) #' d #' #' permute(d, c(3, 2, 1, 4, 5)) #' #' permute(d, "Spectral") #' #' # Permute a list #' l <- list(a = 1:5, b = letters[1:3], c = 0) #' l #' #' permute(l, c(2, 3, 1)) #' #' # Permute to reorder dendrogram (see also reorder.hclust) #' hc <- hclust(d) #' plot(hc) #' #' plot(permute(hc, 5:1)) #' plot(permute(hc, 5:1, incompartible = "stop")) #' #' plot(permute(hc, "OLO", dist = d)) #' plot(permute(hc, "GW", dist = d)) #' plot(permute(hc, "MDS", dist = d)) #' plot(permute(hc, "TSP", dist = d)) #' @export permute <- function(x, order, ...) UseMethod("permute") #' @export permute.default <- function(x, order, ...) .permute_kd(x, order, ...) #' @rdname permute #' @export permute.array <- function(x, order, margin = NULL, ...) .permute_kd(x, order, margin = margin, ...) #' @rdname permute #' @export permute.matrix <- function(x, order, margin = NULL, ...) .permute_kd(x, order, margin = margin, ...) #' @rdname permute #' @export permute.data.frame <- function(x, order, margin = NULL, ...) .permute_kd(x, order, margin = margin, ...) #' @rdname permute #' @export permute.table <- function(x, order, margin = NULL, ...) .permute_kd(x, order, margin = margin, ...) #' @rdname permute #' @export permute.numeric <- function(x, order, ...) .permute_1d(x, order, ...) #' @rdname permute #' @export permute.character <- function(x, order, ...) .permute_1d(x, order, ...) #' @rdname permute #' @export permute.list <- function(x, order, ...) .permute_1d(x, order, ...) # special cases #' @rdname permute #' @export permute.dist <- function(x, order, ...) { order <- find_order(x, order, ...) if (.is_identity_permutation(order[[1]])) return(x) .check_dist_perm(x, order) .rearrange_dist(x, get_order(order, 1)) } #' @rdname permute #' @export permute.dendrogram <- function(x, order, dist = NULL, ...) { # order can be # * TRUE/FALSE # * a numeric vector # * a ser_permutation of length 1 # * a ser_permutation vector # * a seriation method (requires dist) if (is.logical(order)) { if(!order) return(x) else order <- "OLO" } if (is.character(order)) { if (is.null(dist)) stop("dist need for seriation-based reordering.") suppressWarnings(order <- seriate(dist, method = order, hclust = x, ...)) } # modeled after rotate in dendextend. Copied here to reduce the heavy dependency count of dendextend. # x <- dendextend::rotate(x, order = match(get_order(order), get_order(x))) rot <- function (x, order, ...) { if (length(get_order(order)) != stats::nobs(x)) stop("Length of order and number of leaves in dendrogram do not agree!") if (missing(order)) { warning("'order' parameter is missing, returning the tree as it was.") return(x) } labels_x <- labels(x) order_x <- order.dendrogram(x) number_of_leaves <- length(order_x) if (!is.numeric(order)) { order <- as.character(order) if (length(intersect(order, labels_x)) != number_of_leaves) { stop( "'order' is neither numeric nor a vector with ALL of the labels (in the order you want them to be)" ) } order <- match(order, labels_x) } weights <- seq_len(number_of_leaves) weights_for_order <- numeric(number_of_leaves) weights_for_order[order_x[order]] <- weights reorder(x, weights_for_order, mean, ...) } x <- rot(x, order = match(get_order(order), get_order(x))) if (any(get_order(x) != get_order(order))) warning("Dendrogram cannot be perfectly reordered! Using best approximation.") x } #' @rdname permute #' @export permute.hclust <- function(x, order, dist = NULL, ...) { nd <- stats::as.hclust(permute(stats::as.dendrogram(x), order, dist = dist, ...)) x$merge <- nd$merge x$height <- nd$height x$order <- nd$order x } # helper .check_dist_perm <- function(x, order) { if (inherits(order, "ser_permutation") && length(order) != 1L) stop("dimensions do not match") if (attr(x, "Size") != length(get_order(order, 1))) stop("some permutation vectors do not fit dimension of data") # check dist if (isTRUE(attr(x, "Diag")) || isTRUE(attr(x, "Upper"))) stop("'dist' with diagonal or upper triangle matrix not implemented") } .check_matrix_perm <- function(x, order) { if (ndim(x) != length(order)) stop("dimensions do not match") if (any(dim(x) != sapply(order, length))) stop("some permutation vectors do not fit dimension of data") } .permute_kd <- function(x, order, margin = NULL, ...) { # DEPRECATED: Compatibility with old permutation for data.frame if (is.data.frame(x) && is.null(margin) && !is.character(order) && ( inherits(order, "ser_permutation") && length(order) == 1 || inherits(order, "ser_permutation_vector") || is.integer(order) )) { warning( "permute for data.frames with a single seriation order is now deprecated. Specify the margin as follows: 'permute(x, order, margin = 1)'" ) margin <- 1 } if (is.null(margin)) margin <- seq(ndim(x)) else { margin <- as.integer(margin) if (!all(margin %in% seq(ndim(x)))) stop("all margins need to specify a valid dimension in x") } order <- find_order(x, order, margin = margin, ...) if (length(order) != ndim(x) && length(order) != length(margin)) stop( "order needs to contain either orders for all dimensions of x or just orders for the selected margin." ) # set margins not to be permuted to identity and copy the rest o <- seriate(x, method = "identity") if (length(order) < ndim(x)) ### we only have order for specified margins for(i in seq(length(order))) o[[margin[i]]] <- order[[i]] else for (i in margin) o[[i]] <- order[[i]] # expand identity manual permutations (if any) for (i in which(sapply(o, .is_identity_permutation))) o[[i]] <- ser_permutation_vector(seq(dim(x)[i])) # check .check_matrix_perm(x, o) perm <- lapply(o, get_order) do.call("[", c(list(x), perm, drop = FALSE)) } .permute_1d <- function(x, order, ...) { if (is.logical(order)) { if(order) stop("No default seritation method for vectors avaialble. Specify the order.") else return(x) } order <- ser_permutation(order) if (length(order) != 1) stop("dimensions do not match!") perm <- get_order(order, 1) if (length(x) != length(perm)) stop("The permutation vectors do not fit the length of x!") x[perm] } # if we used proxy we would say: #.rearrange_dist <- function (x, order) x[[order]] # Note: order can be a subset .rearrange_dist <- function (x, order) { # make C call mode(x) <- "double" # as.dist seems to make Size numeric and not integer! attr(x, "Size") <- as.integer(attr(x, "Size")) mode(order) <- "integer" d <- .Call("reorder_dist", x, order) labels <- if (is.null(labels(x))) NULL else labels(x)[order] structure( d, class = "dist", Size = length(order), Labels = labels, Diag = FALSE, Upper = FALSE, method = attr(x, "method") ) } seriation/R/seriate_heatmap.R0000644000176200001440000000761114456247551015750 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ## calculate distances for rows and columns, perform hclust and reorder. .heatmap_contr <- list( dist_fun = list(row = dist, col = dist), seriation_method = list(row = "OLO_complete", col = "OLO_complete"), seriation_control = list(row = NULL, col = NULL), scale = "none", verbose = FALSE ) attr(.heatmap_contr, "help") <- list( dist_fun = "A named list with functions to calulate row and column distances", seriation_method = "A named list with row and column seriation methods", seriation_control = "named list with control parameters for the seriation methods", scale = 'Scale "rows", "cols", or "none"' ) seriate_matrix_heatmap <- function(x, control = NULL, margin = seq_along(dim(x))) { control <- .get_parameters(control, .heatmap_contr) if (length(control$dist_fun) == 1L) control$dist_fun <- list(row = control$dist_fun, col = control$dist_fun) if (length(control$seriation_method) == 1L) control$seriation_method <- list(row = control$seriation_method, col = control$seriation_method) if (length(control$seriation_control) == 1L) control$seriation_control <- list(row = control$seriation_control, col = control$seriation_control) if (!is.null(control$scale)) { if (control$scale == "rows") x <- t(scale(t(x))) if (control$scale == "cols") x <- scale(x) } if (1L %in% margin) { d <- control$dist_fun$row(x) if (tolower(control$seriation_method$row) == "hc_mean") o_row <- ser_permutation_vector(seriate_hc_mean(d, x, control$seriation_control$row), method = "HC_Mean") else o_row <- seriate( d, method = control$seriation_method$row, control = control$seriation_control$row )[[1]] } else o_row <- NA if (2L %in% margin) { x <- t(x) d <- control$dist_fun$col(x) if (tolower(control$seriation_method$col) == "hc_mean") o_col <- ser_permutation_vector(seriate_hc_mean(d, x, control$seriation_control$col), method = "HC_Mean") else o_col <- seriate( d, method = control$seriation_method$col, control = control$seriation_control$col )[[1]] } else o_col <- NA #names(row) <- rownames(x)[get_order(o_row)] #names(col) <- colnames(x)[get_order(o_col)] list(row = o_row, col = o_col) } seriate_hc_mean <- function(d, x, control = NULL) { if (missing(x)) stop("data matrix x needs to be specified for leaf order with mean reordering.") hc <- stats::as.hclust(stats::reorder( stats::as.dendrogram(seriate_dist_hc(d, control)), wts = rowSums(x, na.rm = TRUE) )) hc$call <- match.call() hc$method <- "hclust + mean reordering" hc$dist.method <- attr(d, "method") hc } set_seriation_method( "matrix", "Heatmap", seriate_matrix_heatmap, "Calculates distances for rows and columns and then independently applies the specified seriation method for distances.", control = .heatmap_contr ) seriation/R/seriate_VAT.R0000644000176200001440000000363114330237000014734 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ## VAT: a tool for visual assessment of (cluster) tendency ## Bezdek, J.C., Hathaway, R.J. ## Proceedings of the 2002 International Joint Conference on ## Neural Networks, 2002. IJCNN '02. (Volume:3) seriate_dist_VAT <- function(x, control = NULL) { #param <- .get_parameters(control, NULL) .get_parameters(control, NULL) D <- as.matrix(x) N <- nrow(D) P <- rep(NA_integer_, N) I <- rep(FALSE, N) ### J is !I i <- which(D == max(D, na.rm = TRUE), arr.ind = TRUE)[1, 1] P[1] <- i I[i] <- TRUE for (r in 2:N) { D2 <- D[I, !I, drop = FALSE] j <- which(D2 == min(D2, na.rm = TRUE), arr.ind = TRUE)[1, 2] j <- which(!I)[j] P[r] <- j I[j] <- TRUE } P } set_seriation_method( "dist", "VAT", seriate_dist_VAT, "Visual assesment of clustering tendency (Bezdek and Hathaway (2002). Creates an order based on Prim's algorithm for finding a minimum spanning tree (MST) in a weighted connected graph representing the distance matrix. The order is given by the order in which the nodes (objects) are added to the MST." ) seriation/R/dissplot.R0000644000176200001440000007661214455533105014455 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. #' Dissimilarity Plot #' #' Visualizes a dissimilarity matrix using seriation and matrix shading using #' the method developed by Hahsler and Hornik (2011). Entries with lower #' dissimilarities (higher similarity) are plotted darker. Dissimilarity plots #' can be used to uncover hidden structure in the data and judge cluster #' quality. #' #' The plot can also be used to visualize cluster quality (see Ling 1973). #' Objects belonging to the same cluster are displayed in consecutive order. #' The placement of clusters and the within cluster order is obtained by a #' seriation algorithm which tries to place large similarities/small #' dissimilarities close to the diagonal. Compact clusters are visible as dark #' squares (low dissimilarity) on the diagonal of the plot. Additionally, a #' Silhouette plot (Rousseeuw 1987) is added. This visualization is similar to #' CLUSION (see Strehl and Ghosh 2002), however, allows for using arbitrary #' seriating algorithms. #' #' **Note:** Since [pimage()] uses \pkg{grid}, it should not be mixed #' with base R primitive plotting functions. #' #' @family plots #' #' @param x an object of class [dist]. #' @param labels `NULL` or an integer vector of the same length as #' rows/columns in `x` indicating the cluster membership for each object #' in `x` as consecutive integers starting with one. The labels are used #' to reorder the matrix. #' @param method A single character string indicating the seriation method used #' to reorder the clusters (inter cluster seriation) as well as the objects #' within each cluster (intra cluster seriation). If different algorithms for #' inter and intra cluster seriation are required, `method` can be a #' `list` of two named elements (`inter_cluster` and #' `intra_cluster` each containing the name of the respective seriation #' method. Use [list_seriation_methods()] with `kind = "dist"` to find available algorithms. #' #' Set method to `NA` to plot the matrix as is (no or, if cluster labels #' are supplied, only coarse seriation). For intra cluster reordering with the #' special method `"silhouette width"` is available (for `dissplot()` #' only). Objects in clusters are then ordered by silhouette width (from #' silhouette plots). If no `method` is given, the default method of #' [seriate.dist()] is used. #' #' A third list element (named `aggregation`) can be added to control how #' inter cluster dissimilarities are computed from from the given dissimilarity #' matrix. The choices are `"avg"` (average pairwise dissimilarities; #' average-link), `"min"` (minimal pairwise dissimilarities; single-link), #' `"max"` (maximal pairwise dissimilarities; complete-link), and #' `"Hausdorff"` (pairs up each point from one cluster with the most #' similar point from the other cluster and then uses the largest dissimilarity #' of paired up points). #' @param control a list of control options passed on to the seriation #' algorithm. In case of two different seriation algorithms, `control` #' can contain a list of two named elements (`inter_cluster` and #' `intra_cluster`) containing each a list with the control options for #' the respective algorithm. #' @param upper_tri,lower_tri,diag a logical indicating whether to show the upper triangle, the #' lower triangle or the diagonal of the distance matrix. The string "average" can also be used #' to display within and between cluster averages in the two triangles. #' @param cluster_labels a logical indicating whether to display cluster labels #' in the plot. #' @param cluster_lines a logical indicating whether to draw lines to separate #' clusters. #' @param reverse_columns a logical indicating if the clusters are displayed on #' the diagonal from north-west to south-east (`FALSE`; default) or from #' north-east to south-west (`TRUE`). #' @param options a list with options for plotting the matrix (`dissplot` #' only). #' - `plot` a logical indicating if a plot should #' be produced. if `FALSE`, the returned object can be plotted later #' using the function `plot` which takes as the second argument a list of #' plotting options (see `options` below). #' - `silhouettes` a logical indicating whether to include a silhouette plot #' (see Rousseeuw, 1987). #' - `threshold` a numeric. If used, only plot distances #' below the threshold are displayed. Consider also using `zlim` for this #' purpose. #' - `col` colors used for the image plot. #' - `key` a logical indicating whether to place a color key below the plot. #' - `zlim` range of values to display (defaults to range `x`). #' - `axes` `"auto"` (default; enabled for less than 25 objects), `"y"` or `"none"`. #' - `main` title for the plot. #' - `newpage` a logical indicating whether to start plot on a new page #' (see [grid.newpage()]. #' - `pop` a logical indicating whether to pop the created viewports? #' (see package \pkg{grid}) #' - `gp`, `gp_lines`, `gp_labels` objects of class `gpar` containing graphical parameters for the plot #' lines and labels (see [gpar()]. #' @param ... `dissplot()`: further arguments are added to `options`. #' `ggdissplot()` further arguments are passed on to [ggpimage()]. #' @return `dissplot()` returns an invisible object of class #' `cluster_proximity_matrix` with the following elements: #' \item{order}{`NULL` or integer vector giving the order used to plot `x`.} #' \item{cluster_order}{ `NULL` or integer vector giving the order of the #' clusters as plotted.} #' \item{method}{ vector of character strings indicating #' the seriation methods used for plotting `x`.} #' \item{k}{ `NULL` or integer scalar giving the number of clusters generated.} #' \item{description}{ a `data.frame` containing information (label, size, average #' intra-cluster dissimilarity and the average silhouette) for the clusters as #' displayed in the plot (from top/left to bottom/right).} #' #' This object can be used for plotting via `plot(x, options = NULL, ...)`, #' where `x` is the object and `options` contains a list with #' plotting options (see above). #' #' `ggdissplot()` returns a ggplot2 object representing the plot. #' #' @returns The plot description as an object of class `reordered_cluster_dissimilarity_matrix`. #' #' @author Michael Hahsler #' @references #' Hahsler, M. and Hornik, K. (2011): Dissimilarity plots: A visual #' exploration tool for partitional clustering. \emph{Journal of Computational #' and Graphical Statistics,} \bold{10}(2):335--354. #' \doi{10.1198/jcgs.2010.09139} #' #' Ling, R.F. (1973): A computer generated aid for cluster analysis. #' \emph{Communications of the ACM,} \bold{16}(6), 355--361. #' \doi{10.1145/362248.362263} #' #' Rousseeuw, P.J. (1987): Silhouettes: A graphical aid to the interpretation #' and validation of cluster analysis. \emph{Journal of Computational and #' Applied Mathematics,} \bold{20}(1), 53--65. #' \doi{10.1016/0377-0427(87)90125-7} #' #' Strehl, A. and Ghosh, J. (2003): Relationship-based clustering and #' visualization for high-dimensional data mining. \emph{INFORMS Journal on #' Computing,} \bold{15}(2), 208--230. #' \doi{10.1287/ijoc.15.2.208.14448} #' @keywords hplot cluster #' @examples #' data("iris") #' #' # shuffle rows #' x_iris <- iris[sample(seq(nrow(iris))), -5] #' d <- dist(x_iris) #' #' # Plot original matrix #' dissplot(d, method = NA) #' #' # Plot reordered matrix using the nearest insertion algorithm (from tsp) #' dissplot(d, method = "TSP", main = "Seriation (TSP)") #' #' # Cluster iris with k-means and 3 clusters and reorder the dissimality matrix #' l <- kmeans(x_iris, centers = 3)$cluster #' dissplot(d, labels = l, main = "k-means") #' #' # show only distances as lower triangle #' dissplot(d, labels = l, main = "k-means", lower_tri = TRUE, upper_tri = FALSE) #' #' # Use a grid layout to place several plots on a page #' library("grid") #' grid.newpage() #' pushViewport(viewport(layout=grid.layout(nrow = 2, ncol = 2), #' gp = gpar(fontsize = 8))) #' pushViewport(viewport(layout.pos.row = 1, layout.pos.col = 1)) #' #' # Visualize the clustering (using Spectral between clusters and MDS within) #' res <- dissplot(d, l, method = list(inter = "Spectral", intra = "MDS"), #' main = "K-Means + Seriation", newpage = FALSE) #' #' popViewport() #' pushViewport(viewport(layout.pos.row = 1, layout.pos.col = 2)) #' #' # More visualization options. Note that we reuse the reordered object res! #' # color: use 10 shades red-blue, biased towards small distances #' plot(res, main = "K-Means + Seriation (red-blue + biased)", #' col= bluered(10, bias = .5), newpage = FALSE) #' #' popViewport() #' pushViewport(viewport(layout.pos.row = 2, layout.pos.col = 1)) #' #' # Threshold (using zlim) and cubic scale to highlight differences #' plot(res, main = "K-Means + Seriation (cubic + threshold)", #' zlim = c(0, 2), col = grays(100, power = 3), newpage = FALSE) #' #' popViewport() #' pushViewport(viewport(layout.pos.row = 2, layout.pos.col = 2)) #' #' # Use gray scale with logistic transformation #' plot(res, main = "K-Means + Seriation (logistic scale)", #' col = gray( #' plogis(seq(max(res$x_reordered), min(res$x_reordered), length.out = 100), #' location = 2, scale = 1/2, log = FALSE) #' ), #' newpage = FALSE) #' #' popViewport(2) #' #' # The reordered_cluster_dissimilarity_matrix object #' res #' names(res) #' #' ## -------------------------------------------------------------------- #' ## ggplot-based dissplot #' if (require("ggplot2")) { #' #' library("ggplot2") #' #' # Plot original matrix #' ggdissplot(d, method = NA) #' #' # Plot seriated matrix #' ggdissplot(d, method = "TSP") + #' labs(title = "Seriation (TSP)") #' #' # Cluster iris with k-means and 3 clusters #' l <- kmeans(x_iris, centers = 3)$cluster #' #' ggdissplot(d, labels = l) + #' labs(title = "K-means + Seriation") #' #' # show only lower triangle #' ggdissplot(d, labels = l, lower_tri = TRUE, upper_tri = FALSE) + #' labs(title = "K-means + Seriation") #' #' # No lines or cluster labels and add a label for the color key (fill) #' ggdissplot(d, labels = l, cluster_lines = FALSE, cluster_labels = FALSE) + #' labs(title = "K-means + Seriation", fill = "Distances\n(Euclidean)") #' #' # Diverging color palette with manual set midpoint and different seriation methods #' ggdissplot(d, l, method = list(inter = "Spectral", intra = "MDS")) + #' labs(title = "K-Means + Seriation", subtitle = "biased color scale") + #' scale_fill_gradient2(midpoint = median(d)) #' #' # Use manipulate scale using package scales #' library("scales") #' #' # Threshold (using limit and na.value) and cubic scale to highlight differences #' cubic_dist_trans <- trans_new( #' name = "cubic", #' # note that we have to do the inverse transformation for distances #' trans = function(x) x^(1/3), #' inverse = function(x) x^3 #' ) #' #' ggdissplot(d, l, method = list(inter = "Spectral", intra = "MDS")) + #' labs(title = "K-Means + Seriation", subtitle = "cubic + biased color scale") + #' scale_fill_gradient(low = "black", high = "white", #' limit = c(0,2), na.value = "white", #' trans = cubic_dist_trans) #' #' # Use gray scale with logistic transformation #' logis_2_.5_dist_trans <- trans_new( #' name = "Logistic transform (location, scale)", #' # note that we have to do the inverse transformation for distances #' trans = function(x) plogis(x, location = 2, scale = .5, log = FALSE), #' inverse = function(x) qlogis(x, location = 2, scale = .5, log = FALSE), #' ) #' #' ggdissplot(d, l, method = list(inter = "Spectral", intra = "MDS")) + #' labs(title = "K-Means + Seriation", subtitle = "logistic color scale") + #' scale_fill_gradient(low = "black", high = "white", #' trans = logis_2_.5_dist_trans, #' breaks = c(0, 1, 2, 3, 4)) #' } #' @export dissplot <- function(x, labels = NULL, method = "spectral", control = NULL, lower_tri = TRUE, upper_tri = "average", diag = TRUE, cluster_labels = TRUE, cluster_lines = TRUE, reverse_columns = FALSE, options = NULL, ...) { ## add ... to options options <- c(options, list(...)) options$cluster_labels <- cluster_labels options$cluster_lines <- cluster_lines options$reverse_columns <- reverse_columns ## make x dist if (!inherits(x, "dist")) { if (is.matrix(x) && isSymmetric(x)) x <- as.dist(x) else stop("Argument 'x' cannot safely be coerced to class 'dist'.") } a <- .arrange_dissimilarity_matrix(x, labels = labels, method = method, control = control) if (is.null(options$plot) || options$plot) plot(a, lower_tri, upper_tri, diag, options) invisible(a) } ## work horse .arrange_dissimilarity_matrix <- function(x, labels = NULL, method = NULL, control = NULL) { ## x is already of class dist dim <- attr(x, "Size") diss_measure <- attr(x, "method") ## check labels if (!is.null(labels) && length(labels) != dim) stop("Number of labels in 'labels' does not match dimensions of 'x'.") m <- method ## set everything to NULL first order <- NULL k <- NULL # number of clusters sil <- NULL avgSil <- NULL labels_unique <- NULL cluster_dissimilarities <- NULL ## method$a means method$ aggregation (default is avg) aggregation <- "avg" if (is.list(method) && !is.null(method$a)) aggregation <- method$a if (!is.list(method)) method <- list(inter_cluster = m, intra_cluster = m) m <- pmatch(names(method), c("inter_cluster", "intra_cluster", "aggregation")) if (any(is.na(m))) stop("Unknown method component. Use 'inter_cluster', 'intra_cluster' and 'aggregation'.") names(method) <- c("inter_cluster", "intra_cluster", "aggregation")[m] if (!is.list(control[[1]])) { control <- list(inter_cluster = control, intra_cluster = control) } if (!is.null(method$inter_cluster) && is.na(method$inter_cluster)) { ## no setiation if (!is.null(labels)) { ## do coarse seriation order <- order(labels) k <- length(unique(labels)) ## calculate cluster_dissimilarities for later cluster_dissimilarities <- .cluster_dissimilarity(x, labels, aggregation) aggregation <- attr(cluster_dissimilarities, "method") ## calculate silhouette values for later use sil <- cluster::silhouette(labels, x) } ## else keep the matrix as is -- do not reorder } else if (is.null(labels)) { ## reorder whole matrix if no labels are given order <- seriate(x, method = method$inter_cluster, control = control$inter)[[1]] method$inter_cluster <- if (!is.null(attr(order, "method"))) attr(order, "method") else method$inter_cluster order <- get_order(order) } else{ ## reorder clusters for given labels ## get number of clusters k k <- length(unique(labels)) ## reorder with average pairwise dissimilarites between clusters cluster_dissimilarities <- .cluster_dissimilarity(x, labels, aggregation) aggregation <- attr(cluster_dissimilarities, "method") if (k > 2) { cluster_order <- seriate( as.dist(cluster_dissimilarities), method = method$inter_cluster, control = control$inter )[[1]] method$inter_cluster <- if (!is.null(attr(cluster_order, "method"))) attr(cluster_order, "method") else method$inter_cluster cluster_order <- get_order(cluster_order) } else{ cluster_order <- 1:k } ## calculate silhouette values for later use sil <- cluster::silhouette(labels, x) ## determine order for matrix from cluster order order <- c() if (!is.null(method$intra_cluster) && is.na(method$intra_cluster)) { ## no intra cluster ordering for (i in 1:k) { order <- c(order, which(labels == cluster_order[i])) } ##method$intra_cluster <- NA } else{ ## intra cluster order for (i in 1:k) { take <- which(labels == cluster_order[i]) ## only reorder for >1 elements if (length(take) > 1) { if (is.character(method$intra_cluster) && match( tolower(method$intra_cluster), c("sil", "silhouette", "silhouette width"), nomatch = 0 ) > 0) { intra_order <- order(sil[take, "sil_width"], decreasing = TRUE) method$intra_cluster <- "silhouette width" } else{ ## we use .rearrange_dist instead of permute ## since we take only a subset! block <- .rearrange_dist(x, take) intra_order <- seriate(block, method = method$intra_cluster, control = control$intra)[[1]] method$intra_cluster <- if (!is.null(attr(intra_order, "method"))) attr(intra_order, "method") else method$intra_cluster intra_order <- get_order(intra_order) } order <- c(order, take[intra_order]) } else{ order <- c(order, take) } } } ## reorder cluster_dissimilarities for later cluster_dissimilarities <- cluster_dissimilarities[cluster_order, cluster_order] } ## reorder matrix if (!is.null(order)) { x_reordered <- permute(x, order) labels <- labels[order] } else x_reordered <- x ## prepare for return value cluster_description <- NULL if (!is.null(labels)) { labels_unique <- unique(labels) ## reorder silhouettes sil <- sil[order,] ## calculate avg silhouettes avgSil <- sapply(labels_unique, function(x) mean(sil[sil[, "cluster"] == x, "sil_width"])) ## generate description cluster_description = data.frame( position = c(1:k), label = labels_unique, size = tabulate(labels)[labels_unique], ## FIXME: this is not the average anymore! aggregated_dissimilarity = diag(cluster_dissimilarities)[labels_unique], avg_silhouette_width = avgSil ) } ## clean order from names, etc. attributes(order) <- NULL structure( list( x_reordered = x_reordered, labels = labels, seriation_methods = method, aggregation_method = aggregation, k = k, cluster_dissimilarities = cluster_dissimilarities, sil = sil, order = order, cluster_order = labels_unique, diss_measure = diss_measure, description = cluster_description ), class = "reordered_cluster_dissimilarity_matrix" ) } ## create panels with avg. dissimilarity ## a is an arrangement .average_tri <- function(a, lower_tri = "average", upper_tri = TRUE, diag = TRUE) { if (!inherits(a, "reordered_cluster_dissimilarity_matrix")) stop("a needs to be a reordered_cluster_dissimilarity_matrix") upper_avg <- !is.na(pmatch(tolower(upper_tri), "average")) lower_avg <- !is.na(pmatch(tolower(lower_tri), "average")) k <- a$k labels <- a$labels labels_unique <- a$cluster_order cluster_dissimilarities <- a$cluster_dissimilarities m <- as.matrix(a$x_reordered) ## blank out if FALSE or NA if (is.na(upper_tri) || (is.logical(upper_tri) && !upper_tri)) { m[upper.tri(m)] <- NA upper_tri <- FALSE } if (is.na(lower_tri) || (is.logical(lower_tri) && !lower_tri)) { m[lower.tri(m)] <- NA lower_tri <- FALSE } ## do off-diagonal averages by cluster if (!is.null(cluster_dissimilarities) && !is.null(labels) && (upper_avg || lower_avg)) { for (i in seq(2, k)) { for (j in seq(i - 1)) { ## check empty clusters if (is.na(labels_unique[i])) next if (is.na(labels_unique[j])) next ## lower panels if (lower_avg) { m[labels == labels_unique[i], labels == labels_unique[j]] <- cluster_dissimilarities[i, j] } ## upper panels if (upper_avg) { m[labels == labels_unique[j], labels == labels_unique[i]] <- cluster_dissimilarities[i, j] } } } ## do diagonal for (i in seq(1, k)) { block <- m[labels == labels_unique[i], labels == labels_unique[i]] if (upper_avg) { block[upper.tri(block, diag = TRUE)] <- cluster_dissimilarities[i, i] m[labels == labels_unique[i], labels == labels_unique[i]] <- block } if (lower_avg) { block[lower.tri(block, diag = TRUE)] <- cluster_dissimilarities[i, i] m[labels == labels_unique[i], labels == labels_unique[i]] <- block } } } if (!diag) diag(m) <- NA m } ## plot for reordered_cluster_dissimilarity_matrix #' @rdname dissplot #' @export plot.reordered_cluster_dissimilarity_matrix <- function(x, lower_tri = TRUE, upper_tri = "average", diag = TRUE, options = NULL, ...) { ## add ... to options options <- c(options, list(...)) k <- x$k dim <- attr(x$x_reordered, "Size") labels <- x$labels #labels_unique <- unique(labels) labels_unique <- x$cluster_order m <- .average_tri(x, lower_tri = lower_tri, upper_tri = upper_tri, diag = diag) ## default plot options options <- .get_parameters( options, list( cluster_labels = TRUE, cluster_lines = TRUE, reverse_columns = FALSE, silhouettes = FALSE, col = NULL, threshold = NULL, zlim = NULL, key = TRUE, main = "Dissimilarity Plot", axes = "auto", gp = gpar(), gp_lines = gpar(), gp_labels = gpar(), newpage = TRUE, pop = TRUE ) ) if (is.null(options$col)) options$col <- rev(.sequential_pal()) else options$col <- rev(options$col) i <- pmatch(options$axes, c("auto", "x", "y", "both", "none")) if (is.na(i)) stop("Illegal vaule for axes. Use: 'auto', 'x', 'y', 'both' or 'none'!") options$axes <- c("auto", "x", "y", "both", "none")[i] ## clear page if (options$newpage) grid.newpage() ## do we have silhouettes? if (is.null(x$sil)) options$silhouettes <- FALSE if (options$reverse_columns) m <- m[, ncol(m):1] if (!options$silhouettes) { pushViewport(viewport( layout = grid.layout( 6, 3, widths = unit.c( unit(2, "lines"), # space unit(1, "snpc") - unit(7, "lines"), # image unit(2, "lines") # space ), heights = unit.c( unit(2, "lines"), # title unit(1, "lines"), # space unit(1, "snpc") - unit(7, "lines"), # image unit(1, "lines"), # space unit(1, "lines"), # colorkey unit(2, "lines") # space ) ), gp = options$gp )) main_vp <- viewport( layout.pos.col = 2, layout.pos.row = 1, name = "main" ) image_vp <- viewport(layout.pos.col = 2, layout.pos.row = 3) colorkey_vp <- viewport( layout.pos.col = 2, layout.pos.row = 5, name = "colorkey" ) } else{ ## with silhouettes pushViewport(viewport( layout = grid.layout( 6, 5, widths = unit.c( unit(2, "lines"), # space unit(0.7, "snpc") - unit(2.5, "lines"), # image unit(1, "lines"), # space unit(0.3, "snpc") - unit(2.5, "lines"), # sil unit(2, "lines") # space ), heights = unit.c( unit(2, "lines"), # title unit(2, "lines"), # space unit(0.7, "snpc") - unit(2.5, "lines"), # image unit(1, "lines"), # space unit(1, "lines"), # colorkey unit(2, "lines") # space ) ), gp = options$gp )) main_vp <- viewport( layout.pos.col = 2:4, layout.pos.row = 1, name = "main" ) image_vp <- viewport(layout.pos.col = 2, layout.pos.row = 3) sil_vp <- viewport( layout.pos.col = 4, layout.pos.row = 3, name = "sil" ) colorkey_vp <- viewport( layout.pos.col = 2, layout.pos.row = 5, name = "colorkey" ) } ## main pushViewport(main_vp) grid.text(options$main, gp = gpar(cex = 1.3, fontface = "bold")) upViewport(1) ## silhouette if (options$silhouettes) { ## get and reorder silhouettes s <- x$sil[, "sil_width"] pushViewport(sil_vp) .grid_barplot_horiz(s, xlab = "Silhouette width", gp_bars = gpar(fill = "lightgrey", col = 0)) upViewport(1) } ## image if (is.null(options$zlim)) options$zlim <- range(m, na.rm = TRUE) if (!is.null(options$threshold)) m[m > options$threshold] <- NA pushViewport(image_vp) .grid_image(m, col = options$col, zlim = options$zlim) ## add labels? if (options$axes == "auto" && nrow(m) > 25) options$axes <- "none" if (options$axes != "none") { downViewport("image") #grid.text(colnames(m), y = unit(-1, "lines"), # x=unit(1:ncol(m), "native"), rot=90, just="right") grid.text( rownames(m), x = unit(1, "npc") + unit(1, "lines"), y = unit(1:nrow(m), "native"), just = "left", gp = options$gp_labels ) upViewport(1) } upViewport(1) ## color key? if (options$key) { pushViewport(colorkey_vp) .grid_colorkey(options$zlim, col = options$col, threshold = options$threshold) upViewport(1) } ## plot cluster borders if we have labels and order if (!is.null(labels)) { labels_unique_y <- labels_unique cluster_width_y <- (tabulate(labels)[labels_unique]) cluster_cuts_y <- cumsum(cluster_width_y) cluster_center_y <- cluster_cuts_y - cluster_width_y / 2 if (options$reverse_columns) { labels_unique_x <- rev(labels_unique) cluster_width_x <- (tabulate(labels)[labels_unique_x]) cluster_cuts_x <- cumsum(cluster_width_x) cluster_center_x <- cluster_cuts_x - cluster_width_x / 2 } else{ labels_unique_x <- labels_unique_y cluster_width_x <- cluster_width_y cluster_cuts_x <- cluster_cuts_y cluster_center_x <- cluster_center_y } if (options$cluster_labels) { seekViewport("image") ## above the plot grid.text( labels_unique_x, x = cluster_center_x, y = unit(1, "npc") + unit(1, "lines"), default.units = "native", gp = options$gp_labels ) ## left of the plot grid.text( labels_unique_y, x = unit(-1, "lines"), y = cluster_center_y, default.units = "native", gp = options$gp_labels ) upViewport(2) } if (options$cluster_lines) { ## draw lines separating the clusters #cluster_cuts <- cluster_cuts[-length(cluster_cuts)] ## remove last line seekViewport("image") for (i in 1:(k - 1)) { grid.lines( #x = c(0, dim), x = c(0.5, dim + 0.5), y = cluster_cuts_y[i] + .5, default.units = "native", gp = options$gp_lines ) grid.lines( x = cluster_cuts_x[i] + .5, #y = c(0, dim), y = c(0.5, dim + 0.5), default.units = "native", gp = options$gp_lines ) } upViewport(2) } } if (options$pop) popViewport(1) else upViewport(1) } ## print for reordered_cluster_dissimilarity_matrix #' @rdname dissplot #' @export print.reordered_cluster_dissimilarity_matrix <- function(x, ...) { d <- attr(x$x_reordered, "Size") k <- if (!is.null(x$k)) x$k else NA cat(gettextf("object of class '%s'\n", class(x))) cat("matrix dimensions:", d, "x", d, "\n") cat(gettextf("dissimilarity measure: '%s'\n", x$diss_measure)) cat("number of clusters k:", k, "\n") if (!is.null(x$k)) { cat("\ncluster description\n") print(x$description) } cat("\n") cat("used seriation methods\n") cat(gettextf("inter-cluster: '%s'\n", x$seriation_methods$inter)) cat(gettextf("intra-cluster: '%s'\n", x$seriation_methods$intra)) cat("\n") cat(gettextf( "dissimilarity aggregation method: '%s'\n", x$aggregation_method )) invisible(x) } ## inter and intra cluster dissimilarity matrix from ## a dissimilarity matrix plus labels .cluster_dissimilarity <- function(x, labels, method = c("avg", "min", "max", "Hausdorff")) { method <- match.arg(method) ## FIXME: Implement Hausdorff linkage <- if (method == "avg") mean else if (method == "min") min else if (method == "max") max else if (method == "Hausdorff") .hausdorff else stop("Unknown method.") if (!is.matrix(x)) x <- as.matrix(x) ## kill self-dissimilarities (which are always 0) diag(x) <- NA k <- length(unique(labels)) diss_matrix <- matrix(nrow = k, ncol = k) ## calculate avg. dissimilarity between clusters for (i in 1:k) { slice <- x[labels == i, , drop = FALSE] for (j in 1:i) { block <- slice[, labels == j, drop = FALSE] val <- linkage(block, na.rm = TRUE) ## fix for clusters of size 1 if (is.nan(val)) val <- 0 diss_matrix[i, j] <- val diss_matrix[j, i] <- val } } attr(diss_matrix, "method") <- method diss_matrix } ## implement Hausdorff distance between two sets from a dissimilarity matrix ##d_H = max{sup_x\inX inf_y\inY d(x,y), sup_y\inY inf_x\inX d(x,y)} .hausdorff <- function(block, na.rm = TRUE) max(apply(block, MARGIN = 1, min, na.rm = na.rm), apply(block, MARGIN = 2, min, na.rm = na.rm)) seriation/R/seriate_GSA.R0000644000176200001440000001276614457041635014746 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2017 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ## Simulated annealing reimplimentation following 'arsa.f' by Brusco et al. ## can use any criterion function #' Neighborhood functions for Seriation Method SA #' #' Definition of different local neighborhood functions for the method `"SA"` for [seriate()]. #' #' Local neighborhood functions are `LS_insert`, `LS_swap`, `LS_reverse`, and `LS_mix` #' (1/3 insertion, 1/3 swap and 1/3 reverse). Any neighborhood function can be defined. #' @name LS #' @aliases LS #' @param o an integer vector with the order #' @param pos random positions used for the local move. #' @returns returns the new order vector representing the random neighbor. NULL #' @rdname LS #' @export LS_swap <- function(o, pos = sample.int(length(o), 2)) { tmp <- o[pos[1]] o[pos[1]] <- o[pos[2]] o[pos[2]] <- tmp o } ### insert pos[1] in pos[2] #' @rdname LS #' @export LS_insert <- function(o, pos = sample.int(length(o), 2)) { append(o[-pos[1]], o[pos[1]], after = pos[2] - 1) } #' @rdname LS #' @export LS_reverse <- function(o, pos = sample.int(length(o), 2)) { o[pos[1]:pos[2]] <- o[pos[2]:pos[1]] o } #' @rdname LS #' @export LS_mixed <- function(o, pos = sample.int(length(o), 2)) { switch(sample.int(3, 1), LS_swap(o, pos), LS_insert(o, pos), LS_reverse(o, pos)) } .sa_contr <- list( criterion = "Gradient_raw", cool = 0.5, t_min = 1e-7, localsearch = "LS_insert", try_multiplier = 5, t0 = NA, p_initial_accept = .01, warmstart = "Random", ## use "Random" for random init. ## try try_multiplier x n local search steps verbose = FALSE ) attr(.sa_contr, "help") <- list( criterion = "Criterion measure to optimize", cool = "cooling factor (smaller means faster cooling)", t_min = "stopping temperature", localsearch = "used local search move function", try_multiplier = "number of local move tries per object", t0 = "initial temperature (if NA then it is estimated)", p_initial_accept = "Probability to accept a bad move at time 0 (used for t0 estimation)", warmstart = "permutation or seriation method for warmstart" ) seriate_sa <- function(x, control = NULL) { param <- .get_parameters(control, .sa_contr) n <- attr(x, "Size") localsearch <- get(param$localsearch) if (!is.function(localsearch)) localsearch <- get(localsearch) crit <- param$crit if (is.ser_permutation(param$warmstart)) { .check_dist_perm(x, order = param$warmstart) o <- get_order(param$warmstart) } else{ if (param$verbose) cat("Obtaining initial solution via:", param$warmstart, "\n") o <- get_order(seriate(x, method = param$warmstart)) } z <- criterion(x, o, method = param$criterion, force_loss = TRUE) if (param$verbose) cat("Initial z =", z, "(minimize)\n") iloop <- param$try_multiplier * n t0 <- param$t0 if (is.na(t0)) { # find the starting temperature. Set the probability of the average # (we use median) uphill move to pinitaccept. o_rand <- sample(n) z_rand <- criterion(x, o_rand, method = param$criterion, force_loss = TRUE) z_new <- replicate(iloop, expr = { criterion( x, localsearch(o_rand), method = param$criterion, force_loss = TRUE ) }) deltas <- (z_rand - z_new) deltas[deltas > 0] <- NA avg_delta <- stats::median(deltas, na.rm = TRUE) t0 <- avg_delta / log(param$p_initial_accept) } nloop <- as.integer((log(param$t_min) - log(t0)) / log(param$cool)) if (t0 <= 0) { t0 <- 0 nloop <- 1L } if (param$verbose) cat("Use t0 =", t0, "resulting in", nloop, "iterations with", iloop, "tries each\n\n") zbest <- z temp <- t0 for (i in 1:nloop) { m <- 0L for (j in 1:iloop) { onew <- localsearch(o) znew <- criterion(x, onew, method = crit, force_loss = TRUE) delta <- z - znew # we minimize, delta < 0 is a bad move if (delta > 0 || temp > 0 && runif(1) < exp(delta / temp)) { o <- onew z <- znew m <- m + 1L } } if (param$verbose) { cat( i, "/", nloop, "\ttemp =", signif(temp, 3), "\tz =", z, "\t accepted moves =", m, "/", iloop, "\n" ) } temp <- temp * param$cool } o } set_seriation_method( "dist", "GSA", seriate_sa, "Minimize a specified seriation measure (criterion) using simulated annealing.", .sa_contr, optimizes = .opt (NA, "set via control criterion"), randomized = TRUE ) seriation/R/seriate_TSP.R0000644000176200001440000000323014457043664014770 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. #' @import "TSP" .tsp_control <- structure( list( method = "arbitrary insertion", rep = 10, two_opt = TRUE ), help = list( method = "used TSP method (see ? solve_TSP)", rep = "number of random restarts", two_opt = "use the 2-opt improvement heuristic?" ) ) seriate_dist_tsp <- function(x, control = NULL) { ## add a dummy city for cutting tsp <- insert_dummy(TSP(x), n = 1, label = "cut_here") if (is.null(control)) control <- .tsp_control tour <- solve_TSP(tsp, method = control$method, control = control) o <- cut_tour(tour, cut = "cut_here", exclude_cut = TRUE) o } set_seriation_method( "dist", "TSP", seriate_dist_tsp, "Minimize Hamiltonian path length with a TSP solver.", .tsp_control, randomized = TRUE, optimizes = "Path_length" ) seriation/R/SupremeCourt.R0000644000176200001440000000267314607605742015253 0ustar liggesusers#' Voting Patterns in the Second Rehnquist U.S. Supreme Court #' #' Contains a (a subset of the) decisions for the stable 8-yr #' period 1995-2002 of the second Rehnquist Supreme Court. #' Decisions are aggregated to #' the joint probability for disagreement between judges. #' #' @name SupremeCourt #' @aliases SupremeCourt #' @docType data #' @family data #' @format #' A square, symmetric 9-by-9 matrix with the joint probability for disagreement. #' @references #' Sirovich, L. (2003). A pattern analysis of the second Rehnquist #' U.S. Supreme Court. _Proceedings of the National Academy of Sciences of the United #' States of America,_ **100**, 7432-7437. \doi{10.1073/pnas.1132164100} #' @author Michael Hahsler #' @examples #' data("SupremeCourt") #' #' # a matrix with joint probability of disagreement #' SupremeCourt #' #' # show judges in original alphabetical order #' d <- as.dist(SupremeCourt) #' pimage(d, diag = TRUE, upper = TRUE) #' #' # reorder judges using seriation based on similar decisions #' o <- seriate(d) #' o #' #' pimage(d, o, diag = TRUE, upper = TRUE) #' #' # Use optimal leaf ordering (hierarchical clustering with reordering) #' # which uses a dendrogram #' o <- seriate(d, method = "OLO") #' o #' #' plot(o[[1]]) #' #' # Use multi-dimensional scaling and show the configuration #' o <- seriate(d, method = "sammon") #' o #' #' pimage(d, o, diag = TRUE, upper = TRUE) #' plot_config(o[[1]]) #' @keywords datasets NULL seriation/R/get_order.R0000644000176200001440000000762514450640234014561 0ustar liggesusers#' Extracting Order Information from a Permutation Object #' #' Method to get the order information from an object of class #' [ser_permutation] or [ser_permutation_vector]. Order information #' can be extracted as a permutation vector, a vector containing each #' object's rank or a permutation matrix. #' #' `get_order()` returns the permutation as an integer vector which arranges the #' objects in the seriation order. That is, a vector with the index of the first, #' second, \eqn{..., n}-th object in the order defined by the permutation. #' These permutation vectors can directly be #' used to reorder objects using subsetting with `"["`. \emph{Note:} In #' \pkg{seriation} we usually use these order-based permutation vectors. #' **Note on names:** While R's [order()] returns an unnamed vector, #' `get_order()` returns names (if available). The names are the object label #' corresponding to the index at that position. #' Therefore, the names in the order are in the order after #' the permutation. #' #' `get_rank()` returns the seriation as an integer vector containing the #' rank/position for each objects after the permutation is applied. #' That is, a vector with the position of the first, second, #' \eqn{..., n}-th object after permutation. Note: Use #' `order()` to convert ranks back to an order. #' #' `get_permutation_matrix()` returns a \eqn{n \times n}{n x n} permutation #' matrix. #' #' @family permutation #' #' @param x an object of class [ser_permutation] or #' [ser_permutation_vector]. #' @param dim order information for which dimension should be returned? #' @param ... further arguments are ignored for `get_order()`. For #' `get_rank()` and for `get_permutation_matrix()` the additional #' arguments are passed on to `get_order()` (e.g., as `dim`). #' @return Returns an integer permutation vector/a permutation matrix. #' #' @author Michael Hahsler #' @keywords manip #' @examples #' ## create a random ser_permutation_vector #' ## Note that ser_permutation_vector is a single permutation vector #' x <- structure(1:10, names = paste0("X", 1:10)) #' o <- sample(x) #' o #' #' p <- ser_permutation_vector(o) #' p #' #' get_order(p) #' get_rank(p) #' get_permutation_matrix(p) #' #' ## reorder objects using subsetting, the provided permute function or by #' ## multiplying the with the permutation matrix. We use here #' x[get_order(p)] #' permute(x, p) #' drop(get_permutation_matrix(p) %*% x) #' #' ## ser_permutation contains one permutation vector for each dimension #' p2 <- ser_permutation(p, sample(5)) #' p2 #' #' get_order(p2, dim = 2) #' get_rank(p2, dim = 2) #' get_permutation_matrix(p2, dim = 2) #' @export get_order <- function(x, ...) UseMethod("get_order") #' @export get_order.default <- function(x, ...) stop(gettextf("No permutation accessor implemented for class '%s'. ", class(x))) #' @rdname get_order #' @export get_order.ser_permutation_vector <- function(x, ...) NextMethod() #' @rdname get_order #' @export get_order.ser_permutation <- function(x, dim = 1, ...) get_order(x[[dim]]) #' @rdname get_order #' @export get_order.hclust <- function(x, ...) structure(.Data = x$order, names = x$labels[x$order]) #' @rdname get_order #' @export get_order.dendrogram <- function(x, ...) order.dendrogram(x) #' @rdname get_order #' @export get_order.integer <- function(x, ...) { if (.is_identity_permutation(x)) stop("Cannot get order vector from symbolic identity permutation (undefined length).") structure(as.integer(x), names = names(x)) } #' @rdname get_order #' @export get_order.numeric <- function(x, ...) { structure(order(x), names = names(x)) } ## returns for each object its rank (rank of first, second, etc. object) #' @rdname get_order #' @export get_rank <- function(x, ...) { o <- get_order(x, ...) r <- order(o) names(r) <- names(o)[r] r } #' @rdname get_order #' @export get_permutation_matrix <- function(x, ...) permutation_vector2matrix(get_order(x, ...)) seriation/R/AAA_map.R0000644000176200001440000000437314313070703014017 0ustar liggesusers####################################################################### # Code to map between ranges for continuous variables # Copyright (C) 2011 Michael Hahsler # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ## mapping helper map <- function(x, range = c(0, 1), from.range = NA) { ## deal with infinite values infs <- is.infinite(x) if (any(infs)) { warning( "x contains infinite values. +Inf will be mapped to be mapped to largest value + range and -Inf to smallest value - range." ) min_max <- range(x[!infs], na.rm = TRUE) pos_inf_val <- min_max[2] + (min_max[2] - min_max[1]) neg_inf_val <- min_max[1] - (min_max[2] - min_max[1]) x[infs] <- ifelse(sign(x[infs] > 0), pos_inf_val, neg_inf_val) } ## set from range if (any(is.na(from.range))) from.range <- range(x, na.rm = TRUE) if (length(from.range) != 2L || from.range[1] > from.range[2]) stop('from.range needs to contain 2 numbers (upper <= lower bound).') from.range_width <- from.range[2] - from.range[1] if (length(range) != 2L) stop('range needs to contain 2 numbers (upper and lower bound).') range_width <- range[2] - range[1] ## if all values are the same and no from.range is given, then return the average range if (from.range_width == 0) { x[] <- mean(range) return(x) } ## map to [0,1] x <- (x - from.range[1]) / from.range_width ## map from [0,1] to [range] x <- x * range_width + range[1] x } map_int <- function(x, range = c(1L, 100L), from.range = NA) { if (length(range) == 1L) range <- c(1L, range) as.integer(map(x, c(range[1], range[2]), from.range)) } seriation/R/seriate.array.R0000644000176200001440000000471714457362306015367 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ## seriate general arrays .seriate_array_helper <- function(x, method = "PCA", control = NULL, margin = seq(ndim(x)), datatype = "array", ...) { ## add ... to control if (any(!margin %in% seq(ndim(x)))) stop("illegal margin specified.") control <- c(control, list(...)) if (!is.character(method) || (length(method) != 1L)) stop("Argument 'method' must be a character string.") method <- get_seriation_method(datatype, method) if (!is.null(control$verbose) && control$verbose) cat("Using seriation method: ", method$name, "\n", method$description, "\n\n", sep = "") tm <- system.time(order <- method$fun(x, control, margin)) if (!is.null(control$verbose) && control$verbose) cat("Seriation took", tm[1] + tm[2], "sec\n\n") for (i in margin) if (!is.null(dimnames(x)[[i]]) && is.integer(order[[i]])) names(order[[i]]) <- dimnames(x)[[i]] perm <- do.call("ser_permutation", unname(lapply( order, "ser_permutation_vector", method$name ))) ### make non-seriated margins identity permutations rem <- which(!seq(ndim(x)) %in% margin) if (length(rem) > 0) { perm_ident <- seriate(x, method = "Identity") perm[[rem]] <- perm_ident[[rem]] } perm } #' @rdname seriate #' @include seriate.matrix.R #' @export seriate.array <- function(x, method = "PCA", control = NULL, margin = seq(length(dim(x))), rep = 1L, ...) { if (rep > 1L) return(seriate_rep(x, method, control, rep = rep, margin = margin, ...)) .seriate_array_helper(x, method, control, margin, datatype = "array", ...) } seriation/R/lines_and_ordered_data.R0000644000176200001440000001505414607605202017233 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. #' Create Simulated Data for Seriation Evaluation #' #' Several functions to create simulated data to evaluate different aspects of #' seriation algorithms and criterion functions. #' #' `create_lines_data()` recreates the lines data set used in for [iVAT()] in #' Havens and Bezdeck (2012). #' #' `create_ordered_data()` (Hahsler et al, 2021) is a versatile #' function which creates "orderable" #' 2D data using Gaussian components along a linear or circular path. The #' components are equally spaced (`spacing`) along the path. The default #' spacing of 6 ensures that 2 adjacent components with a standard deviation of #' one along the direction of the path will barely touch. The standard #' deviation along the path is set by `sd1`. The standard deviation #' perpendicular to the path is set by `sd2`. A value larger than zero #' will result in the data not being perfectly orderable (i.e., the resulting #' distance matrix will not be a perfect pre-anti-Robinson matrix and contain #' anti-Robinson violation events after seriation). Note that a circular path #' always creates anti-Robinson violation since the circle has to be broken at #' some point to create a linear order. #' #' @family data #' #' @param n number of data points to create. #' @param k number of Gaussian components. #' @param size relative size (number of points) of components (length of k). #' If `NULL` then all components have the same size. #' @param spacing space between the centers of components. The default of 6 #' means that the components will barely touch at `ds1 = 1` (3 standard #' deviations for each Gaussian component). #' @param path Are the components arranged along a `"linear"` or #' `"circular"` path? #' @param sd1 variation in the direction along the components. A value greater #' than one means the components are mixing. #' @param sd2 variation perpendicular to the direction along the components. A #' value greater than 0 will introduce anti-Robinson violation events. #' @returns a data.frame with the created data. #' #' @author Michael Hahsler #' @seealso [seriate()], [criterion()], [iVAT()]. #' @references #' Havens, T.C. and Bezdek, J.C. (2012): An Efficient Formulation #' of the Improved Visual Assessment of Cluster Tendency (iVAT) Algorithm, #' _IEEE Transactions on Knowledge and Data Engineering,_ **24**(5), #' 813--822. #' #' Michael Hahsler, Christian Buchta and Kurt Hornik (2021). seriation: Infrastructure for #' Ordering Objects Using Seriation. R package version 1.3.2. #' \url{https://github.com/mhahsler/seriation} #' @keywords datasets #' @examples #' ## lines data set from Havens and Bezdek (2011) #' x <- create_lines_data(100) #' plot(x, xlim = c(-5, 5), ylim = c(-3, 3), cex = .2, col = attr(x, "id")) #' d <- dist(x) #' pimage(d, seriate(d, "OLO_single"), col = bluered(100, bias = .5), key = TRUE) #' #' ## create_ordered_data can produce many types of "orderable" data #' #' ## perfect pre-Anti-Robinson matrix (with a single components) #' x <- create_ordered_data(100, k = 1) #' plot(x, cex = .2, col = attr(x, "id")) #' d <- dist(x) #' pimage(d, seriate(d, "MDS"), col = bluered(100, bias=.5), key = TRUE) #' #' ## separated components #' x <- create_ordered_data(100, k = 5) #' plot(x, cex =.2, col = attr(x, "id")) #' d <- dist(x) #' pimage(d, seriate(d, "MDS"), col = bluered(100, bias = .5), key = TRUE) #' #' ## overlapping components #' x <- create_ordered_data(100, k = 5, sd1 = 2) #' plot(x, cex = .2, col = attr(x, "id")) #' d <- dist(x) #' pimage(d, seriate(d, "MDS"), col = bluered(100, bias = .5), key = TRUE) #' #' ## introduce anti-Robinson violations (a non-zero y value) #' x <- create_ordered_data(100, k = 5, sd1 = 2, sd2 = 5) #' plot(x, cex = .2, col = attr(x, "id")) #' d <- dist(x) #' pimage(d, seriate(d, "MDS"), col = bluered(100, bias = .5), key = TRUE) #' #' ## circular path (has always violations) #' x <- create_ordered_data(100, k = 5, path = "circular", sd1 = 2) #' plot(x, cex = .2, col = attr(x, "id")) #' d <- dist(x) #' pimage(d, seriate(d, "OLO"), col = bluered(100, bias = .5), key = TRUE) #' #' ## circular path (with more violations violations) #' x <- create_ordered_data(100, k = 5, path = "circular", sd1 = 2, sd2 = 1) #' plot(x, cex=.2, col = attr(x, "id")) #' d <- dist(x) #' pimage(d, seriate(d, "OLO"), col = bluered(100, bias = .5), key = TRUE) #' @export create_lines_data <- function(n = 250) { n1 <- n / 5 * 2 n2 <- n / 5 n3 <- n / 5 * 2 x1 <- data.frame(x = runif(n1, -5, 5), y = rnorm(n1, mean = 2, sd = .1)) x2 <- data.frame(x = runif(n2, -3, 3), y = rnorm(n2, mean = 0, sd = .1)) x3 <- data.frame(x = runif(n3, -5, 5), y = rnorm(n3, mean = -2, sd = .1)) id <- c(rep(1, times = n1), rep(2, times = n2), rep(3, times = n3)) x <- rbind(x1, x2, x3) o <- sample(nrow(x)) x <- x[o,] id <- id[o] rownames(x) <- 1:nrow(x) attr(x, "id") <- id x } #' @rdname create_lines_data #' @export create_ordered_data <- function(n = 250, k = 2, size = NULL, spacing = 6, path = "linear", sd1 = 1, sd2 = 0) { if (k > n) stop("k needs to be less than n!") path <- match.arg(path, c("linear", "circular")) ## size if (is.null(size)) size <- rep(1, k) else if (length(size) != k) stop("length of size vector and k do not agree!") size <- round(size / sum(size) * n) size[1] <- n - sum(size[-1]) ## create data ids <- rep(1:k, times = size) x <- data.frame(x = rnorm(n, mean = ids * spacing, sd = sd1), y = rnorm(n, mean = 0, sd = sd2)) ## transform if (path == "circular") { p <- k * spacing theta <- x[, 1] / p * 2 * pi r <- p / (2 * pi) + x[, 2] x <- cbind(x = r * sin(theta), y = r * cos(theta)) } ## randomize order o <- sample(nrow(x)) x <- x[o , , drop = FALSE] ids <- ids[o] attr(x, "id") <- ids x } seriation/R/seriate_spectral.R0000644000176200001440000000541514457043516016142 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ## Spectral Seriation ## Ding, C. and Xiaofeng He (2004): Linearized cluster assignment via ## spectral orderingProceedings of the Twenty-first. ## International Conference on Machine learning (ICML '04) ## Minimizes: sum_{i,j} (i-j)^2 * d_{pi_i,pi_j} seriate_dist_spectral <- function(x, control = NULL) { #param <- .get_parameters(control, NULL) .get_parameters(control, NULL) ### calculate Laplacian W <- 1 / (1 + as.matrix(x)) D <- diag(rowSums(W)) L <- D - W ## The Fiedler vector is the eigenvector with the smallest eigenvalue ## eigen reports eigenvectors/values in decreasing order q <- eigen(L) fiedler <- q$vectors[, ncol(W) - 1L] o <- order(fiedler) names(fiedler) <- attr(x, "Labels") attr(o, "configuration") <- fiedler o } seriate_dist_spectral_norm <- function(x, control = NULL) { #param <- .get_parameters(control, NULL) .get_parameters(control, NULL) ### calculate normalized Laplacian W <- 1 / (1 + as.matrix(x)) D_sqrt <- diag(rowSums(1 / W ^ .5)) L <- D_sqrt %*% W %*% D_sqrt z <- eigen(L)$vectors q <- D_sqrt %*% z ## look for the vector with the largest eigenvalue largest_ev <- q[, 2L] o <- order(largest_ev) names(largest_ev) <- attr(x, "Labels") attr(o, "configuration") <- largest_ev o } set_seriation_method( "dist", "Spectral", seriate_dist_spectral, "Spectral seriation (Ding and He 2004) uses a relaxation to minimize the 2-Sum Problem (Barnard, Pothen, and Simon 1993). It uses the order of the Fiedler vector of the similarity matrix's Laplacian.", optimizes = .opt("2SUM", "2-sum criterion") ) set_seriation_method( "dist", "Spectral_norm", seriate_dist_spectral_norm, "Spectral seriation (Ding and He 2004) uses a relaxation to minimize the 2-Sum Problem (Barnard, Pothen, and Simon 1993). It uses the order of the Fiedler vector of the similarity matrix's normalized Laplacian.", optimizes = .opt("2SUM", "2-sum criterion") ) seriation/R/ggbertinplot.R0000644000176200001440000001263114313070703015274 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. #' @rdname bertinplot #' @export ggbertinplot <- function(x, order = NULL, geom = "bar", highlight = TRUE, row_labels = TRUE, col_labels = TRUE, flip_axes = TRUE, prop = FALSE, ...) { check_installed("ggplot2") if (!is.matrix(x)) stop("Argument 'x' must be a matrix.") geom <- match.arg(tolower(geom), choices = c("tile", "rectangle", "circle", "line", "bar", "none")) # reorder if (!is.null(order)) x <- permute(x, order) # change x and y? if (flip_axes) { x <- t(x) tmp <- row_labels row_labels <- col_labels col_labels <- tmp } if (is.logical(highlight) && highlight) highlight <- mean(x, na.rm = TRUE) g <- .ggpimage_empty( x, row_labels = row_labels, col_labels = col_labels, prop = prop, expand = geom != "raster" ) if (col_labels) breaksCol <- ggplot2::waiver() else breaksCol <- NULL if (row_labels) breaksRow <- ggplot2::waiver() else breaksRow <- NULL # put col labels on top (message about replacing scale for x) suppressMessages( g <- g + ggplot2::scale_x_discrete( breaks = breaksRow, position = "top", expand = if (geom != "raster") ggplot2::waiver() else c(0, 0) ) + ggplot2::scale_y_discrete( breaks = breaksCol, position = "right", expand = if (geom != "raster") ggplot2::waiver() else c(0, 0) ) + ggplot2::theme(axis.text.x = ggplot2::element_text(hjust = 0, vjust = .5)) + ggplot2::theme(legend.position = "bottom") ) # add geom # raster does not use highlight if (geom == "tile") g <- g + ggplot2::geom_raster(ggplot2::aes(fill = x)) if (geom == "circle") if (highlight) { suppressMessages( g <- g + ggplot2::geom_point( ggplot2::aes(size = x, fill = x > highlight), color = "black", pch = 21 ) + .gg_logical_pal() + ggplot2::guides(fill = "none", size = "none") ) } else{ g <- g + ggplot2::geom_point(ggplot2::aes(size = x)) } if (geom == "rectangle") if (highlight) { suppressMessages( g <- g + ggplot2::geom_tile( ggplot2::aes( x = col, y = row, height = x / max(x, na.rm = TRUE) * .8, width = x / max(x, na.rm = TRUE) * .8, fill = x > highlight ), color = "black" ) + .gg_logical_pal() + ggplot2::guides(fill = "none") ) } else{ g <- g + ggplot2::geom_tile(ggplot2::aes(height = x / max(x) * .9), width = .8) } # TODO: do not display facet labels when row_labels == FALSE # no highlight for line if (geom == "line") g <- g + ggplot2::geom_line(ggplot2::aes(x = col, y = x, group = row)) + # Note: facets display the lowest level first so we need to reverse them ggplot2::facet_grid(rows = ggplot2::vars(stats::reorder(row, rev(as.integer( row ))))) + ggplot2::theme( strip.text.y.right = ggplot2::element_text(angle = 0, color = "black"), strip.background = ggplot2::element_blank() ) if (geom == "bar") if (highlight) { suppressMessages( g <- g + ggplot2::geom_bar( ggplot2::aes( x = col, y = x, group = row, fill = x > highlight ), stat = "identity", color = "black", width = .8 ) + # Note: facets display the lowest level first so we need to reverse them ggplot2::facet_grid(rows = ggplot2::vars(stats::reorder( row, rev(as.integer(row)) ))) + ggplot2::theme( strip.text.y.right = ggplot2::element_text(angle = 0, color = "black"), strip.background = ggplot2::element_blank() ) + .gg_logical_pal() + ggplot2::guides(fill = "none") ) } else{ g <- g + ggplot2::geom_bar(ggplot2::aes(x = col, y = x, group = row), stat = "identity", width = .8) + # Note: facets display the lowest level first so we need to reverse them ggplot2::facet_grid(rows = ggplot2::vars(stats::reorder(row, rev( as.integer(row) )))) + ggplot2::theme( strip.text.y.right = ggplot2::element_text(angle = 0, color = "black"), strip.background = ggplot2::element_blank() ) } g } seriation/R/seriate_CA.R0000644000176200001440000000364214455265171014611 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ## use the projection on the first principal component to determine the ## order ## use the projection on the first principal component to determine the ## order .ca_contr <- list( dim = 1L, ca_param = NULL ) attr(.ca_contr, "help") <- list( dim = "CA dimension used for reordering", ca_param = "List with parameters for the call to ca::ca()" ) # CA ignores margin seriate_matrix_ca <- function(x, control = NULL, margin = seq_along(dim(x))) { control <- .get_parameters(control, .ca_contr) mat.ca <- do.call(ca::ca, c(list(obj = x), control$ca_param)) rcoord <- mat.ca$rowcoord # row coordinates row <- order(rcoord[, control$dim]) ccoord <- mat.ca$colcoord # col coordinates col <- order(ccoord[, control$dim]) #names(row) <- rownames(x)[row] #names(col) <- colnames(x)[col] list(row = row, col = col) } set_seriation_method( "matrix", "CA", seriate_matrix_ca, "This method calculates a correspondence analysis of the matrix and computes an order according to the scores on a correspondence analysis dimension.", .ca_contr ) seriation/R/AAA_seriation-package.R0000644000176200001440000000253614610035444016632 0ustar liggesusers#' @keywords internal #' #' @section Key functions: #' - Seriation: [seriate()], [criterion()], [get_order()], [permute()] #' - Visualization: [pimage()], [bertinplot()], [hmap()], [dissplot()], [VAT()] #' #' @section Available seriation methods: #' * [A list with the implemented seriation methods](https://mhahsler.github.io/seriation/seriation_methods.html) #' * [A visual comparison between seriation methods](https://mhahsler.github.io/seriation/visual_comparison.html) #' * [A list with the implemented seriation criteria](https://mhahsler.github.io/seriation/seriation_criteria.html) #' #' @section Quickstart guides: #' * [How to reorder heatmaps](https://mhahsler.github.io/seriation/heatmaps.html) #' * [How to reorder correlation matrices](https://mhahsler.github.io/seriation/correlation_matrix.html) #' * [How to evaluate clusters using dissimilarity plots](https://mhahsler.github.io/seriation/seriation_cluster_evaluation.html) #' #' @references Michael Hahsler, Kurt Hornik, and Christian Buchta. Getting things in order: An introduction to the R package seriation. Journal of Statistical Software, 25(3):1--34, March 2008. \doi{10.18637/jss.v025.i03} #' #' @importFrom graphics plot text title #' @importFrom ca ca #' @importFrom stats reorder as.dist hclust runif rnorm dist order.dendrogram prcomp #' @useDynLib seriation, .registration=TRUE "_PACKAGE" seriation/R/criterion.dist.R0000644000176200001440000002437014610025663015544 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. #' @rdname criterion #' @export criterion.dist <- function(x, order = NULL, method = NULL, force_loss = FALSE, ...) { ## check dist (most C code only works with lower-triangle version) if (attr(x, "Diag") || attr(x, "Upper")) x <- as.dist(x, diag = FALSE, upper = FALSE) if (!is.double(x)) mode(x) <- "double" ## check order if (!is.null(order)) { if (!inherits(order, "ser_permutation")) order <- ser_permutation(order) .check_dist_perm(x, order) } else order <- ser_permutation(seq(attr(x, "Size"))) ## get methods if (is.null(method)) method <- list_criterion_methods("dist") method <- lapply(method, function(m) get_criterion_method("dist", m)) crit <- sapply(method, function(m) structure(m$fun(x, order, ...), names = m$name)) if (force_loss) crit <- crit * sapply( method, FUN = function(m) ifelse(m$merit, -1, 1) ) crit } #' @export criterion.default <- criterion.dist ## Wrapper to computing the length of the order under a distance matrix, ## e.g. a tour where the leg between the first and last city is omitted. ## that this is a (Hamilton) path. ## ## Note that this corresponds to the sum of distances along the first ## off diagonal of the ordered distance matrix. criterion_path_length <- function(x, order = NULL, ...) { if (is.null(order)) order <- 1:attr(x, "Size") else order <- get_order(order) .Call("order_length", x, order, PACKAGE = "seriation") } criterion_lazy_path_length <- function(x, order = NULL, ...) { if (is.null(order)) order <- 1:attr(x, "Size") else order <- get_order(order) .Call("lazy_path_length", x, order, PACKAGE = "seriation") } ## Least squares criterion. measures the difference between the ## dissimilarities between two elements and the rank distance ## (PermutMatrix). criterion_least_squares <- function(x, order = NULL, ...) { if (is.null(order)) order <- 1:attr(x, "Size") else order <- get_order(order) .Call("least_squares_criterion", x, order, PACKAGE = "seriation") } ## inertia around the diagonal (see PermutMatrix) criterion_inertia <- function(x, order = NULL, ...) { if (is.null(order)) order <- 1:attr(x, "Size") else order <- get_order(order) .Call("inertia_criterion", x, order, PACKAGE = "seriation") } ## anti-Robinson loss functions (Streng and Schoenfelder 1978, Chen ## 2002) ## method: 1...i, 2...s, 3...w .ar <- function(x, order = NULL, method = 1L) { if (is.null(order)) order <- 1:attr(x, "Size") else order <- get_order(order) .Call("ar", x, order, as.integer(method), PACKAGE = "seriation") } criterion_ar_events <- function(x, order, ...) .ar(x, order, 1L) criterion_ar_deviations <- function(x, order, ...) .ar(x, order, 2L) #criterion_ar_weighted <- function(x, order, ...) .ar(x, order, 3L) .rgar_contr <- structure( list( w = NULL, pct = 100, relative = TRUE ), help = list( w = "window size. Default is to use a pct of 100% of n", pct = "specify w as a percentage of n in (0,100]", relative = "set to FALSE to get the GAR, i.e., the absolute number of AR events in the window." ) ) ## w \in [2,n-1] ## or pct \in [0 and 100%]; 0 -> 2 and 100 -> n-1 criterion_rgar <- function(x, order, w = NULL, pct = 100, relative = TRUE, ...) { if (is.null(order)) order <- 1:attr(x, "Size") else order <- get_order(order) if (is.null(w)) { w <- floor((length(order) - 3L) * pct / 100) + 2L if (w < 1) w <- 1 } if (w < 2 || w >= length(order)) stop("Window w needs to be 2 <= w < length(order) or pct needs to be 0 < pct <= 100!") .Call("rgar", x, order, as.integer(w), as.integer(relative), PACKAGE = "seriation") } .bar_contr <- structure( list( b = NULL ), help = list( b = "band size defaults to a band of 20% of n" ) ) criterion_bar <- function(x, order, b = NULL, ...) { if (is.null(order)) order <- 1:attr(x, "Size") else order <- get_order(order) ### we default to 1/5 if (is.null(b)) b <- max(1, floor(length(order) / 5)) if (b < 1 || b >= length(order)) stop("Band size needs to be 1 <= b < length(order)!") .Call("bar", x, order, as.integer(b), PACKAGE = "seriation") } criterion_gradient_raw <- function(x, order, ...) { if (is.null(order)) order <- 1:attr(x, "Size") else order <- get_order(order) .Call("gradient", x, order, 1L, PACKAGE = "seriation") } criterion_gradient_weighted <- function(x, order, ...) { if (is.null(order)) order <- 1:attr(x, "Size") else order <- get_order(order) .Call("gradient", x, order, 2L, PACKAGE = "seriation") } .A_2SUM <- function(n) outer( 1:n, 1:n, FUN = function(i, j) (i - j) ^ 2 ) criterion_2SUM <- function(x, order, ...) { if (is.null(order)) order <- 1:attr(x, "Size") else order <- get_order(order) # this is sum(diag(A%*%B[o,o])) qap::qap.obj(.A_2SUM(attr(x, "Size")), 1 / (1 + as.matrix(x)), order) } ### Note: We use n-abs(1-j) since QAP needs positive entries in A! .A_LS <- function(n) outer( 1:n, 1:n, FUN = function(i, j) n - abs(i - j) ) criterion_LS <- function(x, order, ...) { if (is.null(order)) order <- 1:attr(x, "Size") else order <- get_order(order) # this is sum(diag(A%*%B[o,o])) qap::qap.obj(.A_LS(attr(x, "Size")), as.matrix(x), order) } # Spearman rank correlation between distances and rank differences of the order criterion_R_dist <- function(x, order, ...) abs(stats::cor(x, stats::dist(get_rank(order), "manhattan"), method = "spearman")) ### these measures are calculated on similarity matrices criterion_ME_dist <- function(x, order, ...) criterion(1 / (1 + as.matrix(x)), c(order, order), "ME") criterion_Moore_stress_dist <- function(x, order, ...) criterion(1 / (1 + as.matrix(x)), c(order, order), "Moore_stress") criterion_Neumann_stress_dist <- function(x, order, ...) criterion(1 / (1 + as.matrix(x)), c(order, order), "Neumann_stress") ### register methods set_criterion_method("dist", "AR_events" , criterion_ar_events, "Anti-Robinson events: The number of violations of the anti-Robinson form (Chen, 2002).", FALSE) set_criterion_method("dist", "AR_deviations", criterion_ar_deviations, "Anti-Robinson deviations: The number of violations of the anti-Robinson form weighted by the deviation (Chen, 2002).", FALSE) ## set_criterion_method("dist", "AR_weighted", criterion_ar_weighted) set_criterion_method("dist", "RGAR", criterion_rgar, "Relative generalized anti-Robinson events: Counts Anti-Robinson events in a variable band of size w around the main diagonal and normalizes by the maximum of possible events (Tien et al, 2008).", FALSE, control = .rgar_contr) set_criterion_method("dist", "BAR", criterion_bar, "Banded Anti-Robinson form criterion: Measure for closeness to the anti-Robinson form in a band of size b (Earle and Hurley, 2015).", FALSE, control = .bar_contr) set_criterion_method("dist", "Gradient_raw" , criterion_gradient_raw, "Gradient measure: Evaluates how well distances increase when moving away from the diagonal of the distance matrix (Hubert et al, 2001).", TRUE) set_criterion_method( "dist", "Gradient_weighted", criterion_gradient_weighted, "Gradient measure (weighted): Evaluates how well distances increase when moving away from the diagonal of the distance matrix (Hubert et al, 2001).", TRUE ) set_criterion_method("dist", "Path_length", criterion_path_length, "Hamiltonian path length: Sum of distances by following the permutation (Caraux and Pinloche, 2005).", FALSE) set_criterion_method("dist", "Lazy_path_length", criterion_lazy_path_length, "Lazy path length: A weighted version of the Hamiltonian path criterion where later distances are less important (Earl and Hurley, 2015).", FALSE) set_criterion_method("dist", "Inertia", criterion_inertia, "Inertia criterion: Measures the moment of the inertia of dissimilarity values around the diagonal of the distance matrix (Caraux and Pinloche, 2005).", TRUE) set_criterion_method("dist", "Least_squares", criterion_least_squares, "Least squares criterion: The sum of squared differences between distances and the rank differences (Caraux and Pinloche, 2005).", FALSE) set_criterion_method("dist", "ME", criterion_ME_dist, "Measure of effectiveness applied to the reordered similarity matrix (McCormick, 1972).", TRUE) set_criterion_method("dist", "Rho", criterion_R_dist, "Absolute value of the Spearman rank correlation between original distances and rank differences of the order.", TRUE) set_criterion_method( "dist", "Moore_stress", criterion_Moore_stress_dist, "Stress criterion (Moore neighborhood) applied to the reordered similarity matrix (Niermann, 2005).", FALSE ) set_criterion_method( "dist", "Neumann_stress", criterion_Neumann_stress_dist, "Stress criterion (Neumann neighborhood) applied to the reordered similarity matrix (Niermann, 2005).", FALSE ) set_criterion_method("dist", "2SUM", criterion_2SUM, "2-Sum Criterion: The 2-Sum loss criterion multiplies the similarity between objects with the squared rank differences (Barnard, Pothen and Simon, 1993).", FALSE) set_criterion_method("dist", "LS", criterion_LS, "Linear Seriation Criterion: Weights the distances with the absolute rank differences (Hubert and Schultz, 1976).", FALSE) seriation/R/seriate_QAP.R0000644000176200001440000000722614457043334014746 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ## QAP 2SUM seriation seriate_dist_2SUM <- function(x, control = NULL) { ## param are passed on to QAP do.call(qap::qap, c(list( A = .A_2SUM(attr(x, "Size")), B = 1 / (1 + as.matrix(x)) ), control)) } ## QAP Linear seriation seriate_dist_LS <- function(x, control = NULL) { ## param are passed on to QAP do.call(qap::qap, c(list(A = .A_LS(attr( x, "Size" )), B = as.matrix(x)), control)) } ## QAP Inertia seriate_dist_Inertia <- function(x, control = NULL) { ## param are passed on to QAP n <- attr(x, "Size") ## inertia uses the same A matrix as 2SUM ## we use n^2 since A needs to be positive do.call(qap::qap, c(list( A = n ^ 2 - .A_2SUM(n), B = as.matrix(x) ), control)) } ## QAP BAR .qap_bar_contr <- structure(list( b = function(n) max(1, floor(n * .2)) ), help = list(b = "bandwidth (default is 20%)")) seriate_dist_BAR <- function(x, control = NULL) { ## param are passed on to QAP if (is.null(control)) control <- .qap_bar_contr if (is.null(control$b)) control$b <- .qap_bar_contr$b .A_BAR <- function(n, b) { b <- floor(b) if (b < 1 || b >= n) stop("b: needs to be 1<=b n) stop("BAR bandwidth is not between 1 and n!") control$b <- NULL ## inertia uses the same A matrix as 2SUM do.call(qap::qap, c(list(A = .A_BAR(n, b = b), B = as.matrix(x)), control)) } set_seriation_method( "dist", "QAP_2SUM", seriate_dist_2SUM, "Quadratic assignment problem formulation for seriation solved using a simulated annealing solver to minimize the 2-Sum Problem criterion (Barnard, Pothen, and Simon 1993).", randomized = TRUE, optimizes = .opt("2SUM", "2-sum criterion") ) set_seriation_method( "dist", "QAP_LS", seriate_dist_LS, "Quadratic assignment problem formulation for seriation solved using a simulated annealing solver to minimize the Linear Seriation Problem (LS) criterion (Hubert and Schultz 1976).", randomized = TRUE, optimizes = .opt("LS", "Linear seriation criterion") ) set_seriation_method( "dist", "QAP_BAR", seriate_dist_BAR, "Quadratic assignment problem formulation for seriation solved using a simulated annealing solver to minimize the banded anti-Robinson form (BAR).", .qap_bar_contr, randomized = TRUE, optimizes = .opt("BAR", "Banded anti-robinson form") ) set_seriation_method( "dist", "QAP_Inertia", seriate_dist_Inertia, "Quadratic assignment problem formulation for seriation solved using a simulated annealing solver to minimize the Inertia criterion.", randomized = TRUE, optimizes = .opt("Inertia") ) seriation/R/seriate.data.frame.R0000644000176200001440000000231414457362306016242 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. #' @rdname seriate #' @export seriate.data.frame <- function(x, method = "Heatmap", control = NULL, margin = c(1L, 2L), rep = 1L, ...) { if (rep > 1L) return(seriate_rep(x, method, control, rep = rep, margin = margin, ...)) .seriate_array_helper(as.matrix(x), method, control, margin, datatype = "matrix", ...) } seriation/R/seriate_random.R0000644000176200001440000000370014440720003015561 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. seriate_dist_random <- function(x, control = NULL) { #param <- .get_parameters(control, NULL) .get_parameters(control, NULL) o <- 1:attr(x, "Size") sample(o) } seriate_matrix_random <- function(x, control, margin = seq_along(dim(x))) { control <- .get_parameters(control, NULL) lapply(seq_along(dim(x)), function(i) if (i %in% margin) sample(seq(dim(x)[i])) else NA) } set_seriation_method("dist", "Random", seriate_dist_random, "Random permutation", randomized = TRUE, optimized = "None") set_seriation_method("matrix", "Random", seriate_matrix_random, "Random permutation", randomized = TRUE, optimized = "None") set_seriation_method("array", "Random", seriate_matrix_random, "Random permutation", randomized = TRUE, optimized = "None") seriation/R/hmap.R0000644000176200001440000004134114456263005013530 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. #' Plot Heat Map Reordered Using Seriation #' #' Provides heatmaps reordered using several different seriation methods. This #' includes dendrogram based reordering with optimal leaf order and matrix #' seriation-based heat maps. #' #' For dendrogram based heat maps, the arguments are passed on to #' [stats::heatmap()] in \pkg{stats}. The following arguments for `heatmap()` #' cannot be used: `margins`, `Rowv`, `Colv`, `hclustfun`, `reorderfun`. #' #' For seriation-based heat maps further arguments include: #' - `gp` an object of class `gpar` containing graphical #' parameters (see [gpar()] in package \pkg{grid}). #' - `newpage` a logical indicating whether to start plot on a new #' page #' - `prop` a logical indicating whether the height and width of `x` should #' be plotted proportional to its dimensions. #' - `showdist` Display seriated dissimilarity matrices? Values are #' `"none"`, `"both"`, `"rows"` or `"columns"`. #' - `key` logical; show a colorkey? #' - `key.lab` Label plotted next to the color key. #' - `margins` bottom and right-hand-side margins are calculated #' automatically or can be specifies as a vector of two numbers (in lines). #' - `zlim` range of values displayed. #' - `col`, `col_dist` color palettes used. #' #' @family plots #' #' @param x a matrix or a dissimilarity matrix of class dist. If a #' dissimilarity matrix is used, then the `distfun` is ignored. #' @param distfun function used to compute the distance (dissimilarity) between #' both rows and columns. For `gghmap()`, this #' parameter is passed on in `control`. #' @param method a character strings indicating the used seriation algorithm #' (see [seriate.dist()]). #' If the method results in a dendrogram then #' [stats::heatmap()] is used to show the dendrograms, otherwise #' reordered distance matrices are shown instead. #' @param control a list of control options passed on to the seriation #' algorithm specified in `method`. #' @param scale character indicating if the values should be centered and #' scaled in either the row direction or the column direction, or none. Default #' is none. #' @param plot_margins character indicating what to show in the margins. Options are: #' `"auto"`, `"dendrogram"`, `"distances"`, or `"none"`. #' @param col a list of colors used. #' @param col_dist colors used for displaying distances. #' @param row_labels,col_labels a logical indicating if row and column labels #' in `x` should be displayed. If `NULL` then labels are displayed #' if the `x` contains the appropriate dimname and the number of labels is #' 25 or less. A character vector of the appropriate length with labels can #' also be supplied. #' @param prop logical; change the aspect ratio so cells in the image have a #' equal width and height. #' @param \dots further arguments passed on to [stats::heatmap()]. #' @return An invisible list with elements: #' \item{rowInd, colInd}{index permutation vectors.} #' \item{reorder_method}{name of the method used to reorder the matrix.} #' #' The list may contain additional elements (dendrograms, colors, etc). #' #' @author Michael Hahsler #' @keywords hplot #' @examples #' data("Wood") #' #' # regular heatmap from package stats #' heatmap(Wood, main = "Wood (standard heatmap)") #' #' # Default heatmap does Euclidean distance, hierarchical clustering with #' # complete-link and optimal leaf ordering. Note that the rows are #' # ordered top-down in the seriation order (stats::heatmap orders in reverse) #' hmap(Wood, main = "Wood (opt. leaf ordering)") #' hmap(Wood, plot_margins = "distances", main = "Wood (opt. leaf ordering)") #' hmap(Wood, plot_margins = "none", main = "Wood (opt. leaf ordering)") #' #' # Heatmap with correlation-based distance, green-red color (greenred is #' # predefined) and optimal leaf ordering and no row label #' dist_cor <- function(x) as.dist(sqrt(1 - cor(t(x)))) #' hmap(Wood, distfun = dist_cor, col = greenred(100), #' main = "Wood (reorded by corr. between obs.)") #' #' # Heatmap with order based on the angle in two-dimensional MDS space. #' hmap(Wood, method = "MDS_angle", col = greenred(100), row_labels = FALSE, #' main = "Wood (reorderd using ange in MDS space)") #' #' # Heatmap for distances #' d <- dist(Wood) #' hmap(d, main = "Wood (Euclidean distances)") #' #' # order-based with dissimilarity matrices #' hmap(Wood, method = "MDS_angle", #' col = greenred(100), col_dist = greens(100, power = 2), #' keylab = "norm. Expression", main = "Wood (reorderd with distances)") #' #' # without the distance matrices #' hmap(Wood, method = "MDS_angle", plot_margins = "none", #' col = greenred(100), main = "Wood (reorderd without distances)") #' #' # Manually create a simple heatmap with pimage. #' o <- seriate(Wood, method = "heatmap", #' control = list(dist_fun = dist, seriation_method = "OLO_ward")) #' o #' #' pimage(Wood, o) #' #' # Note: method heatmap calculates reorderd hclust objects which can be used #' # for many heatmap implementations like the standard implementation in #' # package stats. #' heatmap(Wood, Rowv = as.dendrogram(o[[1]]), Colv = as.dendrogram(o[[2]])) #' #' # ggplot 2 version does not support dendrograms in the margin (for now) #' if (require("ggplot2")) { #' library("ggplot2") #' #' gghmap(Wood) + labs(title = "Wood", subtitle = "Optimal leaf ordering") #' #' # More parameters (see ? ggpimage): reverse column order and flip axes, make a proportional plot #' gghmap(Wood, reverse_columns = TRUE) + #' labs(title = "Wood", subtitle = "Optimal leaf ordering") #' #' gghmap(Wood, flip_axes = TRUE) + #' labs(title = "Wood", subtitle = "Optimal leaf ordering") #' #' gghmap(Wood, flip_axes = TRUE, prop = TRUE) + #' labs(title = "Wood", subtitle = "Optimal leaf ordering") #' #' dist_cor <- function(x) as.dist(sqrt(1 - cor(t(x)))) #' gghmap(Wood, distfun = dist_cor) + #' labs(title = "Wood", subtitle = "Reorded by correlation between observations") + #' scale_fill_gradient2(low = "darkgreen", high = "red") #' #' gghmap(d, prop = TRUE) + #' labs(title = "Wood", subtitle = "Euclidean distances, reordered") #' #' # Note: the ggplot2-based version currently cannot show distance matrices #' # in the same plot. #' #' # Manually seriate and plot as pimage. #' o <- seriate(Wood, method = "heatmap", control = list(dist_fun = dist, #' seriation_method = "OLO_ward")) #' o #' #' ggpimage(Wood, o) #' } #' @export hmap <- function(x, distfun = stats::dist, method = "OLO_complete", control = NULL, scale = c("none", "row", "column"), plot_margins = "auto", col = NULL, col_dist = grays(power = 2), row_labels = NULL, col_labels = NULL, ...) { scale <- match.arg(scale) plot_margins <- match.arg(plot_margins, c("auto", "dendrogram", "distances", "none")) if (is.null(col)) { if (any(x < 0, na.rm = TRUE)) col <- .diverge_pal() else col <- .sequential_pal() } # dist or matrix? if (inherits(x, "dist")) { dist_row <- dist_col <- x o <- seriate(x, method = method, control = control)[[1]] o <- ser_permutation(o, o) x <- as.matrix(x) # dist uses reversed colors! col <- rev(col) } else { if (!is.matrix(x)) x <- as.matrix(x) o <- seriate( x, "Heatmap", seriation_method = method, dist_fun = distfun, seriation_control = control, scale = scale ) } if (plot_margins == "auto") { if (all(sapply(o, inherits, "hclust"))) plot_margins <- "dendrogram" else plot_margins <- "distances" } if (plot_margins == "dendrogram" && !all(sapply(o, inherits, "hclust"))) { warning( "Dendrogramms not available for all dimensions! Plotting distance matrices instead." ) plot_margins <- "distances" } if (plot_margins == "dendrogram") { # heatmap by default scales rows: we don't want that! # options are ignored for now: we use ... stats::heatmap( x, Rowv = stats::as.dendrogram(rev(o[[1]])), Colv = stats::as.dendrogram(o[[2]]), scale = scale, col = col, labRow = row_labels, labCol = col_labels, ... ) } else if (plot_margins == "distances") { ### we plot seriated distance matrices #pimage(x, o, col = col, row_labels = row_labels, col_labels = col_labels, ...) .hmap_dist( x, method, dist_row = distfun(x), dist_col = distfun(t(x)), o, col = col, col_dist = col_dist, row_labels = row_labels, col_labels = col_labels, ... ) } else pimage(x, o, col = col, row_labels = row_labels, col_labels = col_labels, ...) ## return permutation indices return(invisible(list( o = o, seriation_method = method ))) } ## grid-based dissimilarity plot with seriation .hmap_dist <- function(x, method, dist_row, dist_col, o, ...) { o_row <- o[[1]] o_col <- o[[2]] ## options options <- list(...) options <- .get_parameters( options, list( col = if (any(x < 0)) .diverge_pal() else .sequential_pal(), col_dist = grays, prop = FALSE, main = NULL, key = TRUE, keylab = "", row_labels = NULL, col_labels = NULL, showdist = "both", symm = FALSE, margins = NULL, zlim = if (any(x < 0, na.rm = TRUE)) max(abs(range(x, na.rm = TRUE))) * c(-1, 1) else range(x, na.rm = TRUE), newpage = TRUE, gp = gpar() ) ) options$col_dist <- rev(options$col_dist) .showdist_options <- c("none", "row", "column", "both") options$showdist <- .showdist_options[pmatch(options$showdist, .showdist_options)] if (is.na(options$showdist)) stop("Unknown value for showdist. Use one of: ", paste(dQuote(.showdist_options), collapse = ", ")) ## if symmetric then we only use o_row and dist_row if (length(o_row) == length(o_col) && options$symm == TRUE) { o_col <- o_row dist_col <- dist_row } x <- permute(x, ser_permutation(o_row, o_col)) if (options$showdist == "none") { pimage( x, col = options$col, main = options$main, zlim = options$zlim, row_labels = options$row_labels, col_labels = options$col_labels, prop = options$prop, key = options$key, newpage = options$newpage, gp = options$gp ) return() } dist_row <- permute(dist_row, o_row) dist_col <- permute(dist_col, o_col) # deal with row/col labels row_labels <- options$row_labels col_labels <- options$col_labels if (!is.null(row_labels) && !is.logical(row_labels)) { if (length(row_labels) != nrow(x)) stop("Length of row_labels does not match the number of rows of x.") rownames(x) <- row_labels row_labels <- TRUE } if (!is.null(col_labels) && !is.logical(col_labels)) { if (length(col_labels) != ncol(x)) stop("Length of col_labels does not match the number of columns of x.") colnames(x) <- col_labels col_labels <- TRUE } if (is.null(row_labels)) if (!is.null(rownames(x)) && nrow(x) < 25) { row_labels <- TRUE } else{ row_labels <- FALSE } if (is.null(col_labels)) if (!is.null(colnames(x)) && ncol(x) < 25) { col_labels <- TRUE } else{ col_labels <- FALSE } if (is.null(rownames(x))) rownames(x) <- seq(nrow(x)) if (is.null(colnames(x))) colnames(x) <- seq(ncol(x)) ## Note: we need a list to store units! if (is.null(options$margins)) { options$margins <- list(unit(1, "lines"), unit(1, "lines")) if (col_labels) options$margins[[1]] <- max(stringWidth(colnames(x))) + unit(2, "lines") if (row_labels) options$margins[[2]] <- max(stringWidth(rownames(x))) + unit(2, "lines") all_names <- c("", if (col_labels) colnames(x), if (row_labels) rownames(x)) options$margins[[3]] <- max(stringWidth(all_names)) + unit(2, "lines") } else options$margins <- list( unit(options$margins[1], "lines"), unit(options$margins[2], "lines"), unit(max(options$margins), "lines") ) ## plot if (options$newpage) grid.newpage() ## surrounding viewport pushViewport(viewport( layout = grid.layout( nrow = 3 , ncol = 3, widths = unit.c( unit(1, "lines"), unit(1, "snpc") - options$margins[[3]] - unit(3, "lines"), options$margins[[2]] ), heights = unit.c( unit(3, "lines"), # main unit(1, "snpc") - options$margins[[3]] - unit(3, "lines"), options$margins[[1]] ) ), width = unit(1, "snpc"), height = unit(1, "snpc"), gp = options$gp )) ## main title if (!is.null(options$main)) { pushViewport(viewport(layout.pos.row = 1, layout.pos.col = 2)) grid.text(options$main, gp = gpar(cex = 1.3)) upViewport(1) } ## plots if (options$prop) { widths <- unit.c( unit(1 - ncol(x) / sum(ncol(x), nrow(x)), "npc") - unit(.25, "lines"), unit(.5, "lines"), unit(ncol(x) / sum(ncol(x), nrow(x)), "npc") - unit(.25, "lines") ) heights <- unit.c( unit(1 - nrow(x) / sum(ncol(x), nrow(x)), "npc") - unit(.25, "lines"), unit(.5, "lines"), #space unit(nrow(x) / sum(ncol(x), nrow(x)), "npc") - unit(.25, "lines") ) } else{ heights <- widths <- unit.c(unit(1, "null"), unit(.5, "lines"), # space unit(1, "null")) } pushViewport( viewport( layout = grid.layout( nrow = 3, ncol = 3, widths = widths, heights = heights ), width = unit(1, "snpc"), height = unit(1, "snpc"), layout.pos.row = 2, layout.pos.col = 2 ) ) # data pushViewport(viewport(layout.pos.row = 3, layout.pos.col = 3)) .grid_image(x, col = options$col, gp = options$gp, zlim = options$zlim) downViewport("image") if (col_labels) grid.text( colnames(x), y = unit(-1, "lines"), x = unit(1:ncol(x), "native"), rot = 90, just = "right" ) # , gp=options$gp) if (row_labels) grid.text( rownames(x), x = unit(1, "npc") + unit(1, "lines"), y = unit(1:nrow(x), "native"), just = "left" ) #, gp=options$gp) popViewport(1) popViewport(1) # rows if (options$showdist %in% c("row", "both")) { pushViewport(viewport(layout.pos.row = 3, layout.pos.col = 1)) .grid_image(as.matrix(dist_row), col = options$col_dist, gp = options$gp) popViewport(1) } # cols if (options$showdist %in% c("column", "both")) { pushViewport(viewport(layout.pos.row = 1, layout.pos.col = 3)) .grid_image(as.matrix(dist_col), col = options$col_dist, gp = options$gp) popViewport(1) } # colorkey if (options$key) { pushViewport(viewport(layout.pos.row = 1, layout.pos.col = 1)) pushViewport(viewport( width = unit(0.5, "npc"), height = unit(1, "lines") )) .grid_colorkey( options$zlim, col = options$col, lab = options$keylab, gp = options$gp ) popViewport(2) } popViewport(2) } seriation/R/Townships.R0000644000176200001440000000161014607571522014600 0ustar liggesusers#' Bertin's Characteristics of Townships #' #' This data contains nine characteristics for 16 townships. The data #' set was used by Bertin (1981) to illustrate that the conciseness #' of presentation can be improved by seriating the rows and columns. #' #' @name Townships #' @aliases Townships #' @family data #' @docType data #' @format #' A matrix with 16 0-1 variables (columns) indicating the presence #' (`1`) or absence (`0`) of characteristics of townships #' (rows). #' @references #' Bertin, J. (1981): _Graphics and Graphic Information Processing_. Berlin, Walter de Gruyter. #' @author Michael Hahsler #' @examples #' data("Townships") #' #' ## original data #' pimage(Townships) #' criterion(Townships) #' #' ## seriated data #' order <- seriate(Townships, method = "BEA", control = list(rep = 5)) #' pimage(Townships, order) #' criterion(Townships, order) #' @keywords datasets NULL seriation/R/seriate.dist.R0000644000176200001440000000364014457361737015215 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. #' @rdname seriate #' @export seriate.dist <- function(x, method = "Spectral", control = NULL, rep = 1L, ...) { if (rep > 1L) return(seriate_rep(x, method, control, rep = rep, ...)) ## add ... to control control <- c(control, list(...)) ## check x if (anyNA(x)) stop("NAs not allowed in distance matrix x!") if (any(x < 0)) stop("Negative distances not supported!") if (!is.character(method) || (length(method) != 1L)) stop("Argument 'method' must be a character string.") method <- get_seriation_method("dist", method) if (!is.null(control$verbose) && control$verbose) cat("Using seriation method: ", method$name, "\n", method$description, "\n\n", sep = "") tm <- system.time(order <- method$fun(x, control = control)) if (is.integer(order)) names(order) <- labels(x)[order] if (!is.null(control$verbose) && control$verbose) cat("Seriation took", tm[1] + tm[2], "sec\n\n") ser_permutation(ser_permutation_vector(order, method = method$name)) } seriation/R/seriate_MDS.R0000644000176200001440000001045614457043106014744 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. # MDS: cmdscale .mds_control <- list(add = FALSE) attr(.mds_control, "help") <- list(add = "make the distances Euclidean using an additive constant (see ? cmdscale)") seriate_dist_mds <- function(x, control = NULL) { ### accept deprecated method if (!is.null(control$method)) { control$method <- NULL warning("seriation method mds: control parameter method is deprecated and ignored!") } control <- .get_parameters(control, .mds_control) # eig = TRUE makes sure we get a list back sc <- stats::cmdscale(x, k = 1, eig = TRUE, add = control$add) sc <- drop(sc$points) o <- order(sc) attr(o, "configuration") <- sc o } # isoMDS: MASS::isoMDS .mds_isoMDS_control <- list( add = 1e-9, # to avoid 0 distances maxit = 50, trace = FALSE, tol = 1e-3, p = 2 ) attr(.mds_isoMDS_control, "help") <- list( add = "small constant to avoid 0 distances", maxit = "maximum number of iterations", trace = "trace optimization", tol = "convergence tolerance", p = "power for Minkowski distance in the configuration space" ) seriate_dist_mds_isoMDS <- function(x, control = NULL) { control <- .get_parameters(control, .mds_isoMDS_control) sc <- MASS::isoMDS( x + control$add, k = 1, maxit = control$maxit, trace = control$trace, tol = control$tol, p = control$p ) o <- order(sc$points[, 1]) attr(o, "configuration") <- sc$points[, 1] o } # Sammon mapping: MDS::sammon .mds_sammon_control <- list( add = 1e-9, # to avoid 0 distances niter = 100, trace = FALSE, magic = 0.2, tol = 1e-4 ) attr(.mds_sammon_control, "help") <- list( add = "small constant to avoid 0 distances", niter = "maximum number of iterations", trace = "trace optimization", magic = "initial value of the step size constant in diagonal Newton method", tol = "tolerance for stopping in units of stress" ) seriate_dist_mds_sammon <- function(x, control = NULL) { control <- .get_parameters(control, .mds_sammon_control) sc <- MASS::sammon( x + control$add, y = jitter(stats::cmdscale(x, k = 1)), ### fixes issue with duplicates k = 1, niter = control$niter, trace = control$trace, magic = control$magic, tol = control$tol ) o <- order(sc$points[, 1]) attr(o, "configuration") <- sc$points[, 1] o } ## Angle between the first 2 PCS. Friendly (2002) seriate_dist_angle <- function(x, control = NULL) { control <- .get_parameters(control, .mds_control) sc <- stats::cmdscale(x, k = 2, eig = TRUE, add = control$add) sc <- sc$points o <- .order_angle(sc) attr(o, "configuration") <- sc o } set_seriation_method( "dist", "MDS", seriate_dist_mds, "Order along the 1D classical metric multidimensional scaling", control = .mds_control, optimizes = .opt("MDS_stress", "Euclidean distances") ) set_seriation_method( "dist", "MDS_angle", seriate_dist_angle, "Order by the angular order in the 2D MDS projection space split by the larges gap", control = .mds_control ) set_seriation_method( "dist", "isoMDS", seriate_dist_mds_isoMDS, "Order along the 1D Kruskal's non-metric multidimensional scaling", control = .mds_isoMDS_control, optimizes = .opt("MDS_stress", "with monotonic transformation") ) set_seriation_method( "dist", "Sammon_mapping", seriate_dist_mds_sammon, "Order along the 1D Sammon's non-linear mapping", control = .mds_sammon_control, optimizes = .opt("MDS_stress", "scale free, weighted stress called Sammon's error") ) seriation/R/seriate_SGD.R0000644000176200001440000000512614457043452014740 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2017 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. .sgd_contr <- structure( list( criterion = "Gradient_raw", init = "Spectral", max_iter = NULL, localsearch = "LS_insert", verbose = FALSE ), help = list( criterion = "Criterion measure to optimize", init = "Start permutation or name of a seriation method", max_iter = "number of iterations", localsearch = "used local search move function" ) ) seriate_sgd <- function(x, control = NULL) { param <- .get_parameters(control, .sgd_contr) n <- attr(x, "Size") if (is.numeric(param$init)) { .check_dist_perm(x, order = param$init) o <- get_order(param$init) } else{ if (param$verbose) cat("Obtaining initial solution via:", param$init, "\n") o <- get_order(seriate(x, method = param$init)) } localsearch <- get(param$localsearch) if (!is.function(localsearch)) localsearch <- get(localsearch) crit <- param$criterion max_iter <- control$max_iter if (is.null(max_iter)) max_iter <- 100 * n z <- criterion(x, o, method = crit, force_loss = TRUE) if (param$verbose) { cat("Initial z =", z, "(minimize)\n") cat("\nTry\n") } zbest <- z for (i in seq(max_iter)) { o_new <- localsearch(o) z_new <- criterion(x, o_new, method = crit, force_loss = TRUE) delta <- z - z_new # we minimize, delta < 0 is a bad move if (delta > 0) { o <- o_new z <- z_new if (param$verbose) cat(i, "/", max_iter, "\tz =", z, "\n") } } o } set_seriation_method( "dist", "SGD", seriate_sgd, "Improve an existing solution using stochastic gradient descent.", .sgd_contr, optimizes = .opt (NA, "set via control criterion"), randomized = TRUE ) seriation/R/ggpimage.R0000644000176200001440000001461714456631603014374 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ## image method that makes a proper image plot of a matrix. ## the rows and columns are swapped and the order of the ## columns (original rows) is reversed. #' @rdname pimage #' @include pimage.R #' @export ggpimage <- function(x, order = NULL, ...) UseMethod("ggpimage") ### Note for matrix large values are dark, for dist large values are light! #' @rdname pimage #' @export ggpimage.matrix <- function(x, order = NULL, zlim = NULL, upper_tri = TRUE, lower_tri = TRUE, diag = TRUE, row_labels = NULL, col_labels = NULL, prop = isSymmetric(x), flip_axes = FALSE, reverse_columns = FALSE, ...) { check_installed("ggplot2") force(prop) x <- as.matrix(x) # check data if (all(is.na(x))) stop("all data missing in x.") if (any(is.infinite(x))) stop("x contains infinite entries.") # reorder if (!is.null(order)) x <- permute(x, order) # mask triangles if (any(!upper_tri || !lower_tri || !diag) && nrow(x) != ncol(x)) stop("Upper triangle, lower triangle or diag can only be suppressed for square matrices!") if (!upper_tri) x[upper.tri(x)] <- NA if (!lower_tri) x[lower.tri(x)] <- NA if (!diag) diag(x) <- NA # reverse order of columns if (reverse_columns) x <- x[, seq(ncol(x), 1)] # change x and y? if (flip_axes) { x <- t(x) tmp <- row_labels row_labels <- col_labels col_labels <- tmp } # plot g <- .ggpimage_empty( x, zlim = zlim, row_labels = row_labels, col_labels = col_labels, prop = prop, expand = FALSE ) g <- g + ggplot2::geom_raster(ggplot2::aes(fill = x)) g } #' @export ggpimage.default <- ggpimage.matrix ## small values are dark #' @rdname pimage #' @export ggpimage.dist <- function(x, order = NULL, zlim = NULL, upper_tri = TRUE, lower_tri = TRUE, diag = TRUE, row_labels = NULL, col_labels = NULL, prop = TRUE, flip_axes = FALSE, reverse_columns = FALSE, ...) { check_installed("ggplot2") # reorder specific for dist (we have only a single permutation) if (!is.null(order)) x <- permute(x, order) if (flip_axes) warning("flipping axes has no effect for distance matrices.") g <- ggpimage.matrix( as.matrix(x), order = NULL, zlim = zlim, upper_tri, lower_tri, diag, row_labels, col_labels, prop = prop, flip_axes = FALSE, reverse_columns = reverse_columns, ... ) # reverse color for dist suppressMessages(g <- g + .gg_sequential_pal(dist = TRUE, limits = zlim)) g } ### Note for matrix large values are dark, for dist large values are light! .ggpimage_empty <- function(x, zlim = NULL, row_labels = NULL, col_labels = NULL, prop = TRUE, expand = TRUE) { check_installed("ggplot2") x <- as.matrix(x) # check data if (all(is.na(x))) stop("all data missing in x.") if (any(is.infinite(x))) stop("x contains infinite entries.") # deal with row/col labels if (!is.null(row_labels) && !is.logical(row_labels)) { if (length(row_labels) != nrow(x)) stop("Length of row_labels does not match the number of rows of x.") rownames(x) <- row_labels row_labels <- TRUE } if (!is.null(col_labels) && !is.logical(col_labels)) { if (length(col_labels) != ncol(x)) stop("Length of col_labels does not match the number of columns of x.") colnames(x) <- col_labels col_labels <- TRUE } if (is.null(row_labels)) if (!is.null(rownames(x)) && nrow(x) < 25) { row_labels <- TRUE } else{ row_labels <- FALSE } if (is.null(col_labels)) if (!is.null(colnames(x)) && ncol(x) < 25) { col_labels <- TRUE } else{ col_labels <- FALSE } if (is.null(rownames(x))) rownames(x) <- seq(nrow(x)) if (is.null(colnames(x))) colnames(x) <- seq(ncol(x)) # convert to data.frame with row, col and x x_df <- data.frame( row = factor(rep(seq(nrow( x )), times = ncol(x)), levels = seq(nrow(x), 1)), col = factor(rep(seq(ncol( x )), each = nrow(x)), levels = seq(ncol(x))), x = as.vector(x) ) if (!is.null(rownames(x))) levels(x_df[["row"]]) <- rev(rownames(x)) if (!is.null(colnames(x))) levels(x_df[["col"]]) <- colnames(x) # plot g <- ggplot2::ggplot(x_df, ggplot2::aes(y = row, x = col)) # axes (row and col labels) if (expand) expand <- ggplot2::waiver() else expand <- c(0, 0) if (col_labels) breaksCol <- ggplot2::waiver() else breaksCol <- NULL if (row_labels) breaksRow <- ggplot2::waiver() else breaksRow <- NULL g <- g + ggplot2::scale_x_discrete(breaks = breaksCol, expand = expand) + ggplot2::scale_y_discrete(breaks = breaksRow, expand = expand) # no axis or legend labels g <- g + ggplot2::labs(x = NULL, y = NULL, fill = NULL) g <- g + ggplot2::theme(axis.text.x = ggplot2::element_text( angle = 90, hjust = 1, vjust = .5 )) if (prop) g <- g + ggplot2::theme(aspect.ratio = nrow(x) / ncol(x)) # colors scales if (is.logical(x)) { col <- .gg_logical_pal() # colors for diverging } else if (!is.null(zlim)) { if (min(zlim) < 0) col <- .gg_diverge_pal(limits = zlim) else col <- .gg_sequential_pal(limits = zlim) } else { if (any(x < 0, na.rm = TRUE)) { col <- .gg_diverge_pal(limits = zlim) zlim <- max(abs(range(x, na.rm = TRUE))) * c(-1, 1) } else col <- .gg_sequential_pal(limits = zlim) } g <- g + col g } seriation/R/seriate_AOE.R0000644000176200001440000000415514535726744014741 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. is_correlation_matrix <- function(x) { if(!isSymmetric(x)) return (FALSE) if(any(diag(x) != 1)) return (FALSE) if(any(x > 1)) return (FALSE) if(any(x < -1)) return (FALSE) return(TRUE) } # AOE for correlation matrices seriate_corr_matrix_AOE <- function(x, control = NULL, margin) { if(!is_correlation_matrix(x)) { warning("x is not a correlation matrix. Using method 'PCA_angle' instead.") return(seriate_matrix_angle(x, control, margin)) } sc <- eigen(x)$vectors[, 1:2] o <- .order_angle(sc) list(row = o, col = o) } ## Angle between the first 2 PCs. # Friendly, M. (2002), "Corrgrams: Exploratory Displays for Correlation Matrices," The American Statistician,56, 316-324. # Friendly, M. and Kwan, E. (2003), "Effect ordering for data displays," Computational Statistics & Data Analysis, 43, 509-539. .order_angle <- function(x) { alpha <- atan2(x[, 1], x[, 2]) o <- order(alpha) # cut at largest gap alpha_diff <- diff(c(alpha[o], alpha[o[1]] + 2 * pi)) cut <- which.max(abs(alpha_diff)) if (cut < length(o)) o <- o[c((cut + 1L):length(o), 1:cut)] o } set_seriation_method( "matrix", "AOE", seriate_corr_matrix_AOE, "Order by the angle of the first two eigenvectors (for correlation matrices)", ) seriation/R/register_smacof.R0000644000176200001440000001204214610027232015743 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2015 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. #' Register Seriation Methods from Package smacof #' #' Registers the `"MDS_smacof"` method for [seriate()] based on multidimensional #' scaling using stress majorization and the corresponding `"smacof_stress0"` #' criterion implemented in package smacof (de Leeuw & Mair, 2009). #' #' Seriation method `"smacof"` implements stress majorization with several transformation functions. #' These functions are passed on as the type control parameter. We default #' to `"ratio"`, which together with `"interval"` performs metric MDS. #' `"ordinal"` can be used #' for non-metric MDS. See [smacof::smacofSym()] for details on the #' control parameters. #' #' The corresponding criterion called `"smacof_stress0"` is also registered. #' There additional parameter `type` is used to specify the used #' transformation function. It should agree with the function used for seriation. #' See [smacof::stress0()] for details on the stress calculation. #' #' **Note:** Package \pkg{smacof} needs to be installed. #' #' @aliases registersmacof smacof #' @family seriation #' @returns Nothing. #' #' @references #' Jan de Leeuw, Patrick Mair (2009). Multidimensional Scaling Using Majorization: SMACOF in R. #' _Journal of Statistical Software, 31(3),_ 1-30. \doi{10.18637/jss.v031.i03} #' @keywords optimize cluster #' @examples #' \dontrun{ #' register_smacof() #' #' get_seriation_method("dist", "MDS_smacof") #' #' d <- dist(random.robinson(20, pre = TRUE)) #' #' ## use Banded AR form with default clustering (complete-link) #' o <- seriate(d, "MDS_smacof", verbose = TRUE) #' pimage(d, o) #' #' # recalculate stress for the order #' MDS_stress(d, o) #' #' # ordinal MDS. stress needs to be calculated using the correct type with stress0 #' o <- seriate(d, "MDS_smacof", type = "ordinal", verbose = TRUE) #' criterion(d, o, method = "smacof_stress0", type = "ordinal") #' } #' @export register_smacof <- function() { check_installed("smacof") .smacof_control <- structure( list( type = "ratio", init = "torgerson", relax = FALSE, modulus = 1, itmax = 1000, eps = 1e-06, verbose = FALSE ), help = list( type = 'MDS type: "interval", "ratio", "ordinal" (nonmetric MDS)', init = 'start configuration method ("torgerson"/"random")', relax = "use block relaxation for majorization?", modulus = "number of smacof iterations per monotone regression call", itmax = "maximum number of iterations", eps = "convergence criterion" ) ) seriate_dist_smacof <- function(x, control = NULL) { control <- .get_parameters(control, .smacof_control) r <- smacof::smacofSym( x, ndim = 1, type = control$type, verbose = control$verbose, init = control$init, relax = control$relax, modulus = control$modulus, itmax = control$itmax, eps = control$eps ) if (control$verbose) print(r) config <- drop(r$conf) names(config) <- labels(x) o <- order(config) attr(o, "configuration") <- config o } set_seriation_method( "dist", "MDS_smacof", seriate_dist_smacof, "Seriation based on multidemensional scaling using stress majorization (de Leeuw & Mair, 2009).", .smacof_control, optimizes = .opt("smacof_stress0", "MDS stress"), verbose = TRUE ) .smacof_contr <- structure( list( type = "ratio", warn = FALSE, more = NA ), help = list( type = "MDS type (see ? smacof::stress0)", warn = "produce a warning if the 1D MDS fit does not preserve the given order (see ? seriation::uniscale).", more = "more arguments are passed on to smacof::stress0." ) ) smacof_crit_stress0 <- function(x, order, type = "ratio", warn = FALSE, ...) { conf <- get_config(order) if (is.null(conf)) conf <- uniscale(x, order, warn = warn) smacof::stress0(x, cbind(conf), type = type, ...)$stress } set_criterion_method( "dist", "smacof_stress0", smacof_crit_stress0, "Stress0 calculated for different transformation types from package smacof.", FALSE, verbose = TRUE, control = .smacof_contr ) } seriation/R/VAT.R0000644000176200001440000001125514313070703013227 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. #' Visual Analysis for Cluster Tendency Assessment (VAT/iVAT) #' #' Implements Visual Analysis for Cluster Tendency Assessment (VAT; Bezdek and #' Hathaway, 2002) and Improved Visual Analysis for Cluster Tendency Assessment #' (iVAT; Wang et al, 2010). #' #' `path_dist()` redefines the distance between two objects as the minimum #' over the largest distances in all possible paths between the objects as used #' for iVAT. #' #' @family plots #' #' @param x a \code{dist} object. #' @param upper_tri,lower_tri a logical indicating whether to show the upper or #' lower triangle of the VAT matrix. #' @param ... further arguments are passed on to \code{\link{pimage}} for the #' regular plots and \code{\link{ggpimage}} for the ggplot2 plots. #' @returns Nothing. #' #' @author Michael Hahsler #' @references Bezdek, J.C. and Hathaway, R.J. (2002): VAT: a tool for visual #' assessment of (cluster) tendency. \emph{Proceedings of the 2002 #' International Joint Conference on Neural Networks (IJCNN '02)}, Volume: 3, #' 2225--2230. #' #' Havens, T.C. and Bezdek, J.C. (2012): An Efficient Formulation of the #' Improved Visual Assessment of Cluster Tendency (iVAT) Algorithm, \emph{IEEE #' Transactions on Knowledge and Data Engineering,} \bold{24}(5), 813--822. #' #' Wang L., U.T.V. Nguyen, J.C. Bezdek, C.A. Leckie and K. Ramamohanarao #' (2010): iVAT and aVAT: Enhanced Visual Analysis for Cluster Tendency #' Assessment, \emph{Proceedings of the PAKDD 2010, Part I, LNAI 6118,} 16--27. #' @keywords cluster manip #' @examples #' ## lines data set from Havens and Bezdek (2011) #' x <- create_lines_data(250) #' plot(x, xlim=c(-5,5), ylim=c(-3,3), cex=.2) #' d <- dist(x) #' #' ## create regular VAT #' VAT(d, main = "VAT for Lines") #' ## same as: pimage(d, seriate(d, "VAT")) #' #' ## ggplot2 version #' if (require("ggplot2")) { #' ggVAT(d) + labs(title = "VAT") #' } #' #' ## create iVAT which shows visually the three lines #' iVAT(d, main = "iVAT for Lines") #' ## same as: #' ## d_path <- path_dist(d) #' ## pimage(d_path, seriate(d_path, "VAT for Lines")) #' #' ## ggplot2 version #' if (require("ggplot2")) { #' ggiVAT(d) + labs(title = "iVAT for Lines") #' } #' #' ## compare with dissplot (shows banded structures and relationship between #' ## center line and the two outer lines) #' dissplot(d, method = "OLO_single", main = "Dissplot for Lines", col = bluered(100, bias = .5)) #' #' ## compare with optimally reordered heatmap #' hmap(d, method = "OLO_single", main = "Heatmap for Lines (opt. leaf ordering)", #' col = bluered(100, bias = .5)) #' @export VAT <- function(x, upper_tri = TRUE, lower_tri = TRUE, ...) { if (!inherits(x, "dist")) stop("x needs to be of class 'dist'!") pimage(x, seriate(x, "VAT"), upper_tri = upper_tri, lower_tri = lower_tri, ...) } #' @rdname VAT #' @export iVAT <- function(x, upper_tri = TRUE, lower_tri = TRUE, ...) { if (!inherits(x, "dist")) stop("x needs to be of class 'dist'!") x <- path_dist(x) pimage(x, seriate(x, "VAT"), upper_tri = upper_tri, lower_tri = lower_tri, ...) } ## calculate path distance from iVAT using a modified version fo Floyd's alg. ## d_ij = smallest value of the largest values of all possible paths between i and j #' @rdname VAT #' @export path_dist <- function(x) { #A <- as.matrix(x) #n <- nrow(A) #for(k in 1:n) # for(i in 1:n) # for(j in 1:n) # if(max(A[i,k], A[k,j]) < A[i,j]) A[i,j] <- max(A[i,k], A[k,j]) #d <- as.dist(A) ## make C call m <- as.matrix(x) if (any(is.na(m))) stop("NAs not allowed in x.") if (any(m < 0)) stop("Negative values not allowed in x.") mode(m) <- "double" ## replace Inf with large number m[is.infinite(m)] <- .Machine$double.xmax if (any(m < 0)) stop("Negative values not allowed in x.") m <- .Call("pathdist_floyd", m, PACKAGE = "seriation") as.dist(m) } seriation/R/reorder.hclust.R0000644000176200001440000000740014313070703015535 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. #' Reorder Dendrograms using Optimal Leaf Ordering #' #' Reorder method for dendrograms for optimal leaf ordering. #' #' Minimizes the distance between neighboring objects (leaf nodes) in the #' dendrogram by flipping the order of subtrees. The algorithm by Gruvaeus and #' Wainer is implemented in package \pkg{gclus} (Hurley 2004). #' #' @aliases reorder reorder.hclust #' @param x an object of class \code{hclust}. #' @param dist an object of class \code{dist} with dissimilarities between the #' objects in \code{x}. #' @param method a character string with the name of the used measure. #' Available are: #' - \code{"OLO"} (optimal leaf ordering; Bar-Joseph et al., 2001) implemented in this package and #' - \code{"GW"} (Gruvaeus and Wainer, 1972) from package \pkg{gclus}. #' @param ... further arguments are currently ignored. #' @return A reordered \code{hclust} object. #' @author Michael Hahsler #' @seealso [gclus::reorder.hclust()] #' @references Bar-Joseph, Z., E. D. Demaine, D. K. Gifford, and T. Jaakkola. #' (2001): Fast Optimal Leaf Ordering for Hierarchical Clustering. #' \emph{Bioinformatics,} \bold{17}(1), 22--29. #' #' Gruvaeus, G. and Wainer, H. (1972): Two Additions to Hierarchical Cluster #' Analysis, \emph{British Journal of Mathematical and Statistical Psychology,} #' \bold{25}, 200--206. #' #' Hurley, Catherine B. (2004): Clustering Visualizations of Multidimensional #' Data. \emph{Journal of Computational and Graphical Statistics,} #' \bold{13}(4), 788--806. #' @keywords optimize cluster #' @examples #' ## cluster European cities by distance #' data("eurodist") #' d <- as.dist(eurodist) #' hc <- hclust(eurodist) #' #' ## plot original dendrogram and the reordered dendrograms #' plot(hc) #' plot(reorder(hc, d, method = "GW")) #' plot(reorder(hc, d, method = "OLO")) #' @export reorder.hclust <- function(x, dist, method = "OLO", ...) { method <- match.arg(tolower(method), choices = c("olo", "gw")) ## no reordering for less than 3 objects! if (length(x$order) < 3) return(x) switch(method, olo = .seriate_optimal(x, dist), gw = .seriate_gruvaeus(x, dist)) } ## wrapper for reorder.hclust in gclus .seriate_gruvaeus <- function(hclust, dist) gclus::reorder.hclust(hclust, dist) ## wrapper to the optimal leaf ordering algorithm ## ## ceeboo 2005 .seriate_optimal <- function(hclust, dist) { ## check hclust merge <- hclust$merge if (!is.matrix(merge)) stop("Component 'merge' of argument 'hclust' must be a matrix.") if (length(dim(merge)) != 2) stop("Component 'merge' of argument 'hclust' is invalid.") if (dim(merge)[1] != attr(dist, "Size") - 1) stop("Argument 'dist' and component 'merge' of argument 'hclust' do not conform.") mode(merge) <- "integer" obj <- .Call("order_optimal", dist, merge) names(obj) <- c("merge", "order", "length") ##names(obj$order) <- attr(dist,"Labels") hclust$merge <- obj$merge hclust$order <- obj$order hclust } seriation/R/Psych24.R0000644000176200001440000000252614607604555014050 0ustar liggesusers#' Results of 24 Psychological Test for 8th Grade Students #' #' A data set collected by Holzinger and Swineford (1939) which consists of the #' results of 24 psychological tests given to 145 seventh and eighth grade #' students in a Chicago suburb. This data set contains the correlation matrix #' for the 24 test results. #' The data set was also used as an example for visualization of cluster analysis #' by Ling (1973). #' #' @name Psych24 #' @aliases Psych24 #' @docType data #' @format #' A 24 x 24 correlation matrix. #' @references #' Holzinger, K. L., Swineford, F. (1939): #' A study in factor analysis: The stability of a bi-factor solution. #' _Supplementary Educational Monograph,_ No. **48**. #' Chicago: University of Chicago Press. #' #' Ling, R. L. (1973): A computer generated aid for cluster analysis. #' _Communications of the ACM,_ #' **16**(6), pp. 355--361. #' @examples #' data("Psych24") #' #' ## create a dist object and also get rid of the one negative entry in the #' ## correlation matrix #' d <- as.dist(1 - abs(Psych24)) #' #' pimage(d) #' #' ## do hclust as in Ling (1973) #' hc <- hclust(d, method = "complete") #' plot(hc) #' #' pimage(d, hc) #' #' ## use seriation #' order <- seriate(d, method = "tsp") #' #order <- seriate(d, method = "tsp", control = list(method = "concorde")) #' pimage(d, order) #' @keywords datasets NULL seriation/R/criterion.array.R0000644000176200001440000000360514313070703015710 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ## Criterion for the quality of a permutation of a array .criterion_array_helper <- function(x, order = NULL, method = NULL, datatype = "array", force_loss = FALSE) { ## check order if (!is.null(order)) { if (!inherits(order, "ser_permutation")) stop("Argument 'order' has to be of class 'ser_permutation'.") .check_matrix_perm(x, order) } ## get methods if (is.null(method)) method <- list_criterion_methods(datatype) method <- lapply(method, function(m) get_criterion_method(datatype, m)) crit <- sapply(method, function(m) structure(m$fun(x, order), names = m$name)) if (force_loss) crit <- crit * sapply( method, FUN = function(m) ((as.integer(m$merit) * -2) + 1) ) crit } #' @rdname criterion #' @export criterion.array <- function(x, order = NULL, method = NULL, force_loss = FALSE, ...) .criterion_array_helper(x, order, method, "array", force_loss) seriation/R/seriate_R2E.R0000644000176200001440000000424014530724065014705 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ## uses a sequence of correlation matrices and finds the first matrix ## with rank 2. The elements are projected into the plane spanned by the ## first two eigenvectors. All points are lying on a ellipse. The order ## of the elements on the ellipse is returned (see Chen 2002). seriate_dist_chen <- function(x, control = NULL) { .get_parameters(control, NULL) x <- as.matrix(x) rank <- qr(x)$rank ## find the first correlation matrix of rank 2 n <- 0 while (rank > 2) { x <- stats::cor(x) n <- n + 1 rank <- qr(x)$rank } ## project the matrix on the first 2 eigenvectors e <- eigen(x)$vectors[, 1:2] ## extract the order ## Chen says that he uses the one of the two possible cuts ## that separate the points at rank 1. Since the points just ## separate further towards right and left, cutting on the vertical ## axis of the ellipse yields the same result. right <- which(e[, 1] >= 0) right <- right[order(e[right, 2], decreasing = TRUE)] left <- which(e[, 1] < 0) left <- left[order(e[left, 2])] o <- c(right, left) o } #set_seriation_method("dist", "Chen", seriate_dist_chen, # "Rank-two ellipse seriation") set_seriation_method("dist", "R2E", seriate_dist_chen, "Rank-two ellipse seriation (Chen 2002)") seriation/R/bea.R0000644000176200001440000000467314313070703013332 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ## BEA FORTRAN code by Fionn Murtagh bea <- function(a, istart = 0, jstart = 0) { ## Permute rows and column, using "bond energy algorithm". if (!is.matrix(a)) stop("First input argument must be a matrix.\n") n <- nrow(a) m <- ncol(a) if (n > .Machine$integer.max || m > .Machine$integer.max) stop("Long vectors not supported.") b <- matrix(0.0, n, m) mode(a) <- "single" mode(b) <- "single" ib <- integer(n) jb <- integer(m) ifin <- integer(n) jfin <- integer(m) ener <- 0.0 if (istart == 0) istart <- floor(runif(1, 1, n)) if (jstart == 0) jstart <- floor(runif(1, 1, m)) bea1 <- .Fortran( "rbea", n = as.integer(n), m = as.integer(m), a = as.matrix(a), # input data istart = as.integer(istart), # 1st row placement b = as.matrix(b), # permuted array ib = as.integer(ib), # permuted order of rows ifin = as.integer(ifin), # for book-keeping PACKAGE = "seriation" ) a <- bea1$b bea2 <- .Fortran( "cbea", n = as.integer(n), m = as.integer(m), a = as.matrix(a), # input data jstart = as.integer(jstart), # 1st col. placement b = as.matrix(b), # permuted array jb = as.integer(jb), # permuted order of cols. jfin = as.integer(jfin), # for book-keeping PACKAGE = "seriation" ) energy <- .Fortran( "energy", n = as.integer(n), m = as.integer(m), b = as.matrix(bea2$b), ener = as.single(ener), PACKAGE = "seriation" ) list( b = bea2$b, ib = bea1$ib, jb = bea2$jb, e = energy$ener ) } seriation/R/ser_permutation.R0000644000176200001440000000712014455557646016040 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. #' Class ser_permutation -- A Collection of Permutation Vectors for Seriation #' #' The class `ser_permutation` is a collection of permutation vectors #' (see class [ser_permutation_vector]), one for each dimension (mode) #' of the data to be permuted. #' #' @family permutation #' #' @param x,object an object of class `ser_permutation_vector` or #' any object which can be converted into #' a object of class `ser_permutation` (e.g. an integer #' vector). #' @param ... vectors for further dimensions. #' #' @returns An object of class `ser_permutation`. #' #' @author Michael Hahsler #' @examples #' o <- ser_permutation(1:5, 10:1) #' o #' #' ## length (number of dimensions) #' length(o) #' #' ## get permutation vector for 2nd dimension #' get_order(o, 2) #' #' ## reverse dimensions #' o[2:1] #' #' ## combine #' o <- c(o, ser_permutation(1:15)) #' o #' #' ## get an individual permutation #' o[[2]] #' #' ## reverse the order of a permutation #' o[[2]] <- rev(o[[2]]) #' get_order(o,2) #' @keywords classes #' @export ser_permutation <- function(x, ...) { x <- c(list(x), list(...)) x <- lapply( x, FUN = function(obj) { if (inherits(obj, "ser_permutation")) return(obj) if (inherits(obj, "ser_permutation_vector")) return(list(obj)) return(list(ser_permutation_vector(obj))) } ) x <- unlist(x, recursive = FALSE) class(x) <- c("ser_permutation", "list") x } #' @rdname ser_permutation #' @export print.ser_permutation <- function(x, ...) { writeLines(c( gettextf("object of class %s", paste(sQuote(class( x )), collapse = ", ")), gettextf("contains permutation vectors for %d-mode data\n", length(x)) )) print( data.frame( "vector length" = sapply( x, FUN = function(o) if (.is_identity_permutation(o)) NA_integer_ else length(o) ), "seriation method" = sapply(x, get_method, printable = TRUE), check.names = FALSE ) ) invisible(x) } ## fake summary (we don't really provide a summary, ## but summary produces now a reasonable result --- same as print) #' @rdname ser_permutation #' @export summary.ser_permutation <- function(object, ...) object #' @rdname ser_permutation #' @param recursive ignored. #' @export c.ser_permutation <- function(..., recursive = FALSE) do.call("ser_permutation", list(...)) ## fixme [[<- needs to check for ser_permutation_vector #' @rdname ser_permutation #' @param i index of the dimension(s) to extract. #' @export "[.ser_permutation" <- function(object, i, ...) do.call("ser_permutation", unclass(object)[i]) is.ser_permutation <- function(x) inherits(x, "ser_permutation") | inherits(x, "ser_permutation_vector") seriation/R/seriate_BEA.R0000644000176200001440000000602514457360222014706 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. #' @include seriate_TSP.R .bea_tsp_contr <- .tsp_control seriate_matrix_bea_tsp <- function(x, control, margin = seq_along(dim(x))) { if (any(x < 0)) stop("Requires a nonnegative matrix.") if (1L %in% margin) { criterion <- as.dist(tcrossprod(x)) row <- seriate(max(criterion) - criterion, method = "TSP", control = control)[[1]] attr(row, "method") <- "BEA_TSP" } else row <- NA if (2L %in% margin) { criterion <- as.dist(crossprod(x)) col <- seriate(max(criterion) - criterion, method = "TSP", control = control)[[1]] attr(col, "method") <- "BEA_TSP" } else col <- NA list(row = row, col = col) } ## Bond Energy Algorithm (McCormick 1972) .bea_contr <- list(istart = 0, jstart = 0 ) attr(.bea_contr, "help") <- list(istart = "index of 1st row to be placed (0 = random)", jstart = "index of 1st column to be placed (0 = random)" ) # BEA always does rows and columns so margin is ignored seriate_matrix_bea <- function(x, control = NULL, margin = NULL) { control <- .get_parameters(control, .bea_contr) if (any(x < 0)) stop("Requires a nonnegative matrix.") istart <- control$istart jstart <- control$jstart #rep <- control$rep rep <- 1L res <- replicate(rep, bea(x, istart = istart, jstart = jstart), simplify = FALSE) best <- which.max(sapply(res, "[[", "e")) res <- res[[best]] row <- res$ib col <- res$jb names(row) <- rownames(x)[row] names(col) <- colnames(x)[col] list(row = row, col = col) } ## register methods set_seriation_method( "matrix", "BEA", seriate_matrix_bea, "Bond Energy Algorithm (BEA; McCormick 1972) to maximize the Measure of Effectiveness of a non-negative matrix.", .bea_contr, optimizes = .opt("ME", "Measure of effectiveness"), randomized = TRUE ) set_seriation_method( "matrix", "BEA_TSP", seriate_matrix_bea_tsp, "Use a TSP to optimize the Measure of Effectiveness (Lenstra 1974).", .bea_tsp_contr, optimizes = .opt("ME", "Measure of effectiveness"), randomized = TRUE ) seriation/R/seriate_LLE.R0000644000176200001440000000325514455270275014743 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. .lle_contr <- list( k = 30, reg = 2 ) attr(.lle_contr, "help") <- list( k = "used number of neighbors", reg = "regularization method (see ? lle)" ) seriate_lle <- function(x, control = NULL, margin) { param <- .get_parameters(control, .lle_contr) o <- list(row = NA, col = NA) if (1L %in% margin) { score <- lle(x, m = 1, k = param$k, reg = param$reg) os <- order(score) o$row <- structure(os, names = rownames(x)[os], configuration = score) } if (2L %in% margin) { x <- t(x) score <- lle(x, m = 1, k = param$k, reg = param$reg) os <- order(score) o$col <- structure(os, names = rownames(x)[os], configuration = score) } o } set_seriation_method( "matrix", "LLE", seriate_lle, "Find an order using 1D locally linear embedding.\n", .lle_contr, randomized = FALSE ) seriation/R/register_GA.R0000644000176200001440000001403514607573310014777 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2015 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. #' Register a Genetic Algorithm Seriation Method #' #' Register a GA-based seriation metaheuristic for use with [seriate()]. #' #' Registers the method `"GA"` for [seriate()]. This method can be used #' to optimize any criterion in package \pkg{seriation}. #' #' The GA uses by default the ordered cross-over (OX) operator. For mutation, #' the GA uses a mixture of simple insertion and simple inversion operators. #' This mixed operator is created using #' `seriation::gaperm_mixedMutation(ismProb = .8)`, where `ismProb` #' is the probability that the simple insertion mutation operator is used. See #' package \pkg{GA} for a description of other available cross-over and #' mutation operators for permutations. The appropriate operator functions in #' \pkg{GA} start with `gaperm_`. #' #' We warm start the GA using `"suggestions"` given by several heuristics. #' Set `"suggestions"` to `NA` to start with a purely random initial #' population. #' #' See Example section for available control parameters. #' #' **Note:** Package \pkg{GA} needs to be installed. #' #' @aliases register_GA GA ga gaperm_mixedMutation #' @family seriation #' @returns Nothing. #' #' @author Michael Hahsler #' @references Luca Scrucca (2013): GA: A Package for Genetic Algorithms in R. #' _Journal of Statistical Software,_ **53**(4), 1--37. URL #' \doi{10.18637/jss.v053.i04}. #' @keywords optimize cluster #' @examples #' #' \dontrun{ #' register_GA() #' get_seriation_method("dist", "GA") #' #' data(SupremeCourt) #' d <- as.dist(SupremeCourt) #' #' ## optimize for linear seriation criterion (LS) #' o <- seriate(d, "GA", criterion = "LS", verbose = TRUE) #' pimage(d, o) #' #' ## Note that by default the algorithm is already seeded with a LS heuristic. #' ## This run is no warm start (no suggestions) and increase run to 100 #' o <- seriate(d, "GA", criterion = "LS", suggestions = NA, run = 100, #' verbose = TRUE) #' pimage(d, o) #' #' o <- seriate(d, "GA", criterion = "LS", suggestions = NA, run = 100, #' verbose = TRUE, ) #' #' pimage(d, o) #' } #' @export register_GA <- function() { check_installed("GA") .ga_contr <- structure(list( criterion = "BAR", suggestions = c("TSP", "QAP_LS", "Spectral"), selection = GA::gaperm_lrSelection, crossover = GA::gaperm_oxCrossover, mutation = gaperm_mixedMutation(.8), pcrossover = .8, pmutation = .1, popSize = 100, maxiter = 1000, run = 50, parallel = FALSE, verbose = FALSE ), help = list( criterion = "criterion to be optimized", suggestions = "seed the population with these seriation methods", selection = "selection operator function", crossover = "crossover operator function", mutation = "mutation operator function", pcrossover = "probability for crossover", pmutation = "ptobability of mutations", popSize = "population size", maxiter = "maximum number of generations", run = "stop after run generations without improvement", parallel = "use multiple cores?" )) GA_helper <- function(x, control) { n <- attr(x, "Size") control <- .get_parameters(control, .ga_contr) if (control$verbose) cat("\nPreparing suggestions:", paste0(control$suggestions, collapse = ", "), "\n") if (is.na(control$suggestions[1])) suggestions <- NULL else suggestions <- t(sapply(control$suggestions, function(method) get_order(seriate(x, method = method)))) if (control$verbose) cat("\nStarting GA\n") # fitness function f <- function(o) - criterion(x, as.integer(o), method = control$criterion, force_loss = TRUE) result <- GA::ga( type = "permutation", fitness = f, lower = rep(1L, times = n), upper = rep(n, times = n), selection = control$selection, mutation = control$mutation, crossover = control$crossover, pmutation = control$pmutation, pcrossover = control$pcrossover, suggestions = suggestions, names = as.character(1:n), monitor = control$verbose, parallel = control$parallel, maxiter = control$maxiter, run = control$run, maxFitness = Inf, popSize = control$popSize ) if (control$verbose) if (result@iter < control$maxiter) cat("\nStopped early after", control$run, "iterations with no improvement! (control option 'run')\n") # solution may have multiple rows! Take the first solution. as.integer(result@solution[1, , drop = TRUE]) } set_seriation_method( "dist", "GA", GA_helper, "Use a genetic algorithm to optimize for various criteria.", .ga_contr, randomized = TRUE, optimizes = .opt(NA, "specified as parameter criterion"), verbose = TRUE ) } # Generates a mutation function which mixes simMutation (simple insertion) # with ismMutation (inversion) given the probability. #' @rdname register_GA #' @param ismProb probability to use [GA::gaperm_ismMutation()] (inversion) versus [GA::gaperm_simMutation()] (simple insertion). #' @export gaperm_mixedMutation <- function(ismProb = .8) { function(object, parent, ...) { if (runif(1) > ismProb) GA::gaperm_simMutation(object, parent, ...) else GA::gaperm_ismMutation(object, parent, ...) } } seriation/R/AAA_registry_criterion.R0000644000176200001440000002024414610037740017167 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. #' Registry for Criterion Methods #' #' A registry to manage methods used by [criterion()] to calculate a criterion value given data and a #' permutation. #' #' All methods below are convenience methods for the registry named #' `registry_criterion`. #' #' `list_criterion_method()` lists all available methods for a given data #' type (`kind`). The result is a vector of character strings with the #' short names of the methods. If `kind` is missing, then a list of #' methods is returned. #' #' `get_criterion_method()` returns information (including the #' implementing function) about a given method in form of an object of class #' `"criterion_method"`. #' #' With `set_criterion_method()` new criterion methods can be added by the #' user. The implementing function (`fun`) needs to have the formal #' arguments `x, order, ...`, where `x` is the data object, order is #' an object of class [ser_permutation_vector] and `...` can contain #' additional information for the method passed on from [criterion()]. The #' implementation has to return the criterion value as a scalar. #' #' @name registry_for_criterion_methods #' @family criterion #' #' @param kind the data type the method works on. For example, `"dist"`, #' `"matrix"` or `"array"`. #' @param name the name for the method used to refer to the method in the #' function [criterion()]. #' @param names_only logical; return only the method name. `FALSE` returns #' also the method descriptions. #' @param fun a function containing the method's code. #' @param description a description of the method. For example, a long name. #' @param merit logical; indicating if the criterion measure is a merit #' (`TRUE`) or a loss (`FALSE`) measure. #' @param x an object of class "criterion_method" to be printed. #' @param verbose logical; print a message when a new method is registered. #' @param control a list with control arguments and default values. #' @param ... further information that is stored for the method in the #' registry. #' @returns #' - `list_criterion_method()` results is a vector of character strings with the #' names of the methods used for `criterion()`. #' - `get_criterion_method()` returns a given method in form of an object of class #' `"criterion_method"`. #' @author Michael Hahsler #' @seealso This registry uses [registry::registry]. #' @keywords misc #' @examples #' ## the registry #' registry_criterion #' #' # List all criterion calculation methods by type #' list_criterion_methods() #' #' # List methods for matrix #' list_criterion_methods("matrix") #' #' # get more description #' list_criterion_methods("matrix", names_only = FALSE) #' #' # get a specific method #' get_criterion_method(kind = "dist", name = "AR_d") #' #' # Define a new method (sum of the diagonal elements) #' #' ## 1. implement a function to calculate the measure #' criterion_method_matrix_foo <- function(x, order, ...) { #' if(!is.null(order)) x <- permute(x,order) #' sum(diag(x)) #' } #' #' ## 2. Register new method #' set_criterion_method("matrix", "DiagSum", criterion_method_matrix_foo, #' description = "Calculated the sum of all diagonal entries", merit = FALSE) #' #' list_criterion_methods("matrix") #' get_criterion_method("matrix", "DiagSum") #' #' ## 3. use all criterion methods (including the new one) #' criterion(matrix(1:9, ncol = 3)) #' @export registry_criterion <- registry(registry_class = "criterion_registry", entry_class = "criterion_method") registry_criterion$set_field("kind", type = "character", is_key = TRUE, index_FUN = match_partial_ignorecase) registry_criterion$set_field("name", type = "character", is_key = TRUE, index_FUN = match_partial_ignorecase) registry_criterion$set_field("fun", type = "function", is_key = FALSE) registry_criterion$set_field("description", type = "character", is_key = FALSE) registry_criterion$set_field("merit", type = "logical", is_key = FALSE) registry_criterion$set_field("control", type = "list", is_key = FALSE) #' @rdname registry_for_criterion_methods #' @export list_criterion_methods <- function(kind, names_only = TRUE) { if (missing(kind)) { kinds <- unique(sort(as.vector( sapply(registry_criterion$get_entries(), "[[", "kind") ))) sapply( kinds, FUN = function(k) list_criterion_methods(k, names_only = names_only) ) } else{ if (names_only) sort(as.vector(sapply( registry_criterion$get_entries(kind = kind), "[[", "name" ))) else { l <- registry_criterion$get_entries(kind = kind) l[order(names(l))] } } } #' @rdname registry_for_criterion_methods #' @export get_criterion_method <- function(kind, name) { if (missing(kind)) method <- registry_criterion$get_entry(name = name) else method <- registry_criterion$get_entry(kind = kind, name = name) if (is.null(method)) stop(sQuote(name), " is an unknown criterion. Check list_criterion_methods()") method } ## ## For criterion() methods, argument 'method' really allows selecting ## *several* methods ... should perhaps be called 'methods'? ## We thus have a getter which returns a named list of methods from the ## registry, and a setter for single methods. ## #' @rdname registry_for_criterion_methods #' @export set_criterion_method <- function(kind, name, fun, description = NULL, merit = NA, control = list(), verbose = FALSE, ...) { ## check formals ##if(!identical(names(formals(definition)), ## c("x", "order", "..."))) ## stop("Criterion methods must have formals 'x', 'order', and '...'.") ## check if criterion is already in registry r <- registry_criterion$get_entry(kind = kind, name = name) if (!is.null(r) && r$name == name) { warning("Entry with name ", sQuote(name), " already exists! Modifying entry.") registry_criterion$modify_entry( kind = kind, name = name, fun = fun, description = description, merit = merit, control = control ) } else { registry_criterion$set_entry( kind = kind, name = name, fun = fun, description = description, merit = merit, control = control ) } if (verbose) message("Registering new seriation criteron ", sQuote(name), " for ", sQuote(kind)) } #' @rdname registry_for_criterion_methods #' @export print.criterion_method <- function(x, ...) { writeLines(c( gettextf("name: %s", x$name), gettextf("kind: %s", x$kind), strwrap( gettextf("description: %s", x$description), prefix = " ", initial = "" ), gettextf("merit: %s", x$merit) )) writeLines("additional parameters:") .print_control(x$control) #extra_param <- setdiff(names(as.list(args(x$fun))), c("x", "order", "...", "")) #if (length(extra_param) > 0L) # cat("parameters: ", paste(extra_param, collapse = ", "), "\n") invisible(x) } seriation/R/seriate_HC.R0000644000176200001440000001350214457041577014620 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ## Hierarchical clustering related seriations .hc_control <- list(hclust = NULL, linkage = "complete") attr(.hc_control, "help") <- list(hclust = "a precomputed hclust object (optional)", linkage = "hclust method") .hclust_helper <- function(d, control = NULL) { # Deprecated method control argument if (!is.null(control$method)) { warning("control parameter method is deprecated. Use linkage instead!") control$linkage <- control$method control$method <- NULL } control <- .get_parameters(control, .hc_control) if (!is.null(control$hclust)) return(control$hclust) return(hclust(d, method = control$linkage)) } seriate_dist_hc <- function(x, control = NULL) .hclust_helper(x, control) seriate_dist_hc_single <- function(x, control = NULL) .hclust_helper(x, control = list(linkage = "single")) seriate_dist_hc_average <- function(x, control = NULL) .hclust_helper(x, control = list(linkage = "average")) seriate_dist_hc_complete <- function(x, control = NULL) .hclust_helper(x, control = list(linkage = "complete")) seriate_dist_hc_ward <- function(x, control = NULL) .hclust_helper(x, control = list(linkage = "ward.D2")) seriate_dist_gw <- function(x, control = NULL) reorder(seriate_dist_hc(x, control), x, method = "GW") seriate_dist_gw_single <- function(x, control = NULL) reorder(seriate_dist_hc_single(x, control), x, method = "GW") seriate_dist_gw_average <- function(x, control = NULL) reorder(seriate_dist_hc_average(x, control), x, method = "GW") seriate_dist_gw_complete <- function(x, control = NULL) reorder(seriate_dist_hc_complete(x, control), x, method = "GW") seriate_dist_gw_ward <- function(x, control = NULL) reorder(seriate_dist_hc_ward(x, control), x, method = "GW") seriate_dist_olo <- function(x, control = NULL) reorder(seriate_dist_hc(x, control), x, method = "OLO") seriate_dist_olo_single <- function(x, control = NULL) reorder(seriate_dist_hc_single(x, control), x, method = "OLO") seriate_dist_olo_average <- function(x, control = NULL) reorder(seriate_dist_hc_average(x, control), x, method = "OLO") seriate_dist_olo_complete <- function(x, control = NULL) reorder(seriate_dist_hc_complete(x, control), x, method = "OLO") seriate_dist_olo_ward <- function(x, control = NULL) reorder(seriate_dist_hc_ward(x, control), x, method = "OLO") .hc_desc <- "Using the order of the leaf nodes in a dendrogram obtained by hierarchical clustering" .optHCPL <- .opt("Path_length", "restricted by dendrogram") set_seriation_method("dist", "HC", seriate_dist_hc, .hc_desc, .hc_control) set_seriation_method("dist", "HC_single", seriate_dist_hc_single, paste(.hc_desc, "(single link)")) set_seriation_method( "dist", "HC_complete", seriate_dist_hc_complete, paste(.hc_desc, "(complete link).") ) set_seriation_method("dist", "HC_average", seriate_dist_hc_average, paste(.hc_desc, "(avg. link).")) set_seriation_method("dist", "HC_ward", seriate_dist_hc_ward, paste(.hc_desc, "(Ward's method).")) .gw_desc <- "Using the order of the leaf nodes in a dendrogram obtained by hierarchical clustering and reordered by the Gruvaeus and Wainer (1972) heuristic" set_seriation_method("dist", "GW", seriate_dist_gw, .gw_desc, .hc_control, optimizes = .optHCPL) set_seriation_method( "dist", "GW_single", seriate_dist_gw_single, paste(.gw_desc, "(single link)"), optimizes = .optHCPL ) set_seriation_method( "dist", "GW_average", seriate_dist_gw_average, paste(.gw_desc, "(avg.link)"), optimizes = .optHCPL ) set_seriation_method( "dist", "GW_complete", seriate_dist_gw_complete, paste(.gw_desc, "(complete link)"), optimizes = .optHCPL ) set_seriation_method( "dist", "GW_ward", seriate_dist_gw_ward, paste(.gw_desc, "(Ward's method)"), optimizes = .optHCPL ) .olo_desc <- "Using the order of the leaf nodes in a dendrogram obtained by hierarchical clustering and reordered by with optimal leaf ordering (Bar-Joseph et al., 2001)" set_seriation_method("dist", "OLO", seriate_dist_olo, .olo_desc, .hc_control, optimizes = .optHCPL) set_seriation_method( "dist", "OLO_single", seriate_dist_olo_single, paste(.olo_desc, "(single link)"), optimizes = .optHCPL ) set_seriation_method( "dist", "OLO_average", seriate_dist_olo_average, paste(.olo_desc, "(avg. link)"), optimizes = .optHCPL ) set_seriation_method( "dist", "OLO_complete", seriate_dist_olo_complete, paste(.olo_desc, "(complete link)"), optimizes = .optHCPL ) set_seriation_method( "dist", "OLO_ward", seriate_dist_olo_ward, paste(.olo_desc, "(Ward's method)"), optimizes = .optHCPL ) seriation/R/AAA_defaults.R0000644000176200001440000000107014457344772015063 0ustar liggesusers### helper to determine the default criterion get_seriation_kind <- function(x) { kind <- class(x)[[1]] if (kind %in% c("table", "data.frame")) kind <- "matrix" kind } get_default_criterion <- function(x) { kind <- get_seriation_kind(x) if (kind == "dist") criterion <- "AR_deviations" else if (kind == "matrix") criterion <- "Moore_stress" else stop("Unknown default criterion for type: ", kind) criterion } get_default_method <- function(x) as.list(args(utils::getS3method("seriate", class = class(x)[[1L]])))$method seriation/R/Irish.R0000644000176200001440000000121614607604671013664 0ustar liggesusers#' Irish Referendum Data Set #' #' A data matrix containing the results of 8 referenda for 41 Irish communities #' used in Falguerolles et al (1997). #' #' Column 6 contains the size of the Electorate in 1992. #' #' @name Irish #' @docType data #' @family data #' @format The format is a 41 x 9 matrix. Two values are missing. #' @references de Falguerolles, A., Friedrich, F., Sawitzki, G. (1997) A #' Tribute to J. Bertin's Graphical Data Analysis. In: _Proceedings of the #' SoftStat '97 (Advances in Statistical Software 6),_ 11--20. #' @source The data was kindly provided by Guenter Sawitzki. #' @keywords datasets #' @examples #' data(Irish) NULL seriation/R/seriate.R0000644000176200001440000007422614607607121014246 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. #' Seriate Dissimilarity Matrices, Matrices or Arrays #' #' Tries to find a linear order for objects using data in the form of a #' dissimilarity matrix (two-way one-mode data), a data matrix (two-way #' two-mode data), or a data array (k-way k-mode data). The order can then be #' used to reorder the dissimilarity matrix/data matrix using #' [permute()]. #' #' Seriation methods are managed via a registry. See #' [list_seriation_methods()] for help. In the following, we focus on #' discussing the #' built-in methods that are registered automatically by the package \pkg{seriation}. #' #' The available control options, default settings, and #' a description for each algorithm #' can be retrieved using `get_seriation_method(name = "")`. #' Some control parameters are also described in more detail below. #' #' Some methods are very slow, and progress can be printed using the control #' parameter `verbose = TRUE`. #' #' Many seriation methods (heuristically) optimize (minimize or maximize) an #' objective function often called seriation criterion. #' The value of the seriation criterion for a given order can be #' calculated using [criterion()]. In this manual page, we #' include the criterion, which is optimized by each method using **bold font**. #' If no criterion is mentioned, then the method does not directly optimize a criterion. #' A definition of the different seriation criteria can be found on the [criterion()] manual page. #' #' **Seriation methods for distance matrices (dist)** #' #' One-mode two-way data must be provided as a dist object (not #' a symmetric matrix). Similarities have to be transformed into #' dissimilarities. #' Seriation algorithms fall into different groups based on the approach. #' In the following, we describe the currently implemented methods. #' A list with all methods and the available parameters is available #' [here](https://mhahsler.github.io/seriation/seriation_methods.html). #' [Hahsler (2017)](https://michael.hahsler.net/research/paper/EJOR_seriation_2016.pdf) #' for a more detailed description and an experimental comparison of the most #' popular methods. #' #' #' **Dendrogram leaf order** #' #' These methods create a dendrogram using hierarchical clustering and then derive #' the seriation order from the leaf order in the dendrogram. Leaf reordering #' may be applied. #' #' - **Hierarchical clustering:** `"HC"`, `"HC_single"`, `"HC_complete"`, #' `"HC_average"`, `"HC_ward"` #' #' Uses the order of the leaf nodes in a dendrogram obtained by hierarchical #' clustering as a simple seriation technique. This method #' applies hierarchical clustering ([stats::hclust()]) to `x`. The clustering #' method can be given using a `"linkage"` element in the `control` #' list. If omitted, the default `"complete"` is used. #' For convenience, the other methods are provided as shortcuts. #' #' - **Reordered by the Gruvaeus and Wainer heuristic:** `"GW"`, `"GW_single"`, `"GW_average"`, #' `"GW_complete"`, `"GW_ward"` (Gruvaeus and Wainer, 1972) #' #' Method `"GW"` uses an algorithm developed by Gruvaeus and Wainer (1972) #' as implemented [gclus::reorder.hclust()] (Hurley 2004). The clusters are #' ordered at each level so that the objects at the edge of each cluster are #' adjacent to the nearest object outside the cluster. The #' method produces a unique order. #' #' The methods start with a dendrogram created by [hclust()]. As the #' `"linkage"` element in the `control` list, a clustering method #' (default `"average"`) can be specified. Alternatively, an [stats::hclust] #' object can be supplied using an element named `"hclust"`. #' #' A dendrogram (binary tree) has \eqn{2^{n-1}} internal nodes (subtrees) and #' the same number of leaf orderings. That is, at each internal node, the left #' and right subtree (or leaves) can be swapped or, in terms of a dendrogram, #' be flipped. The leaf-node reordering to minimize #' #' Minimizes the **Hamiltonian path length (restricted by the dendrogram)**. #' #' - **Reordered by optimal leaf ordering:** `"OLO"`, `"OLO_single"`, #' `"OLO_average"`, `"OLO_complete"`, `"OLO_ward"` (Bar-Joseph et al., 2001) #' #' Starts with a dendrogram and #' produces an optimal leaf ordering that minimizes the sum of #' the distances along the (Hamiltonian) path connecting the leaves in the #' given order. The algorithm's time complexity is \eqn{O(n^3)}. Note that #' non-finite distance values are not allowed. #' #' Minimizes the **Hamiltonian path length (restricted by the dendrogram)**. #' #' - **Dendrogram seriation:** `"DendSer"` (Earle and Hurley, 2015) #' #' Use heuristic dendrogram seriation to optimize for various criteria. #' The DendSer code has to be first registered. A #' detailed description can be found on the manual page for #' [register_DendSer()]. #' #' **Dimensionality reduction** #' #' Find a seriation order by reducing the dimensionality to 1 dimension. This is typically #' done by minimizing a stress measure or the reconstruction error. #' Note that dimensionality reduction to a single dimension is a very #' difficult discrete optimization problem. #' For example, MDS algorithms used for a single dimension #' tend to end up in local optima (see Maier and De Leeuw, 2015). #' However, generally, ordering along a single component of MDS provides good results #' sufficient for applications like visualization. #' #' - **Classical metric multidimensional scaling:** `"MDS"` #' #' Orders along the 1D classical metric multidimensional scaling. #' `control` parameters are passed on to [stats::cmdscale()]. #' - **Isometric feature mapping:** `"isomap"` (Tenenbaum, 2000) #' #' Orders along the 1D isometric feature mapping. #' `control` parameters are passed on to [vegan::isomap()] #' #' - **Kruskal's non-metric multidimensional scaling:** `"isoMDS"`, `"monoMDS"`, #' `"metaMDS"` (Kruskal, 1964) #' #' Orders along the 1D Kruskal's non-metric multidimensional scaling. #' Package \pkg{vegan} provides an alternative implementation called `monoMDS` #' and a version that uses random restarts for stability called `metaMDS`. #' `control` parameters are passed on to [MASS::isoMDS()], [vegan::monoMDS()] or [vegan::metaMDS()]. #' #' - **Sammon's non-linear mapping:** `"Sammon_mapping"` (Sammon, 1969) #' #' Orders along the 1D Sammon's non-linear mapping. #' `control` parameters are passed on to [MASS::sammon()]. #' #' #' - **Angular order of the first two eigenvectors:** `"MDS_angle"` #' #' Finds a 2D configuration using MDS ([stats::cmdscale()]) #' to approximate the eigenvectors of the covariance matrix in the #' original data matrix. #' Orders by the angle in this space and splits the order by the #' larges gap between adjacent angles. A similar method was used by #' Friendly (2002) to order variables in correlation matrices #' by angles of first two eigenvectors. #' #' - **Smacof:** `"MDS_smacof"` (de Leeuw and Mair, 2009) #' #' Perform seriation using stress majorization with several transformation functions. #' This method has to be registered first using [`register_smacof()`]. #' #' **Optimization** #' #' These methods try to optimize a seriation criterion directly, typically using a #' heuristic approach. #' #' - **Anti-Robinson seriation by simulated annealing:** `"ARSA"` (Brusco et al 2008) #' #' The algorithm automatically finds a suitable start temperature and calculates #' the needed number of iterations. The algorithm gets slow for a large number of #' objects. The speed can be improved by lowering the cooling parameter `"cool"` #' or increasing the minimum temperature `"tmin"`. #' However, this will decrease the seriation quality. #' #' Directly minimizes the **linear seriation criterion (LS).** #' #' - **Complete Enumeration:** `"Enumerate"` #' #' This method finds the optimal permutation given a seriation criterion by complete enumeration #' of all permutations. #' The criterion is specified as the `control` parameters `"criterion"`. #' Default is the weighted gradient measure. Use `"verbose = TRUE"` to see #' the progress. #' #' Note: The number of permutations for \eqn{n} objects is \eqn{n!}. #' Complete enumeration is only possible for tiny problems (<10 objects) and is limited on most systems #' to a problem size of up to 12 objects. #' #' - **Gradient measure seriation by branch-and-bound:** `"BBURCG"`, `"BBWRCG"` (Brusco and Stahl 2005) #' #' The method uses branch-and-bound to minimize the #' **unweighted gradient measure** (`"BBURCG"`) and the #' **weighted gradient measure** (`"BBWRCG"`). #' This type of optimization is only feasible for a small number of objects (< 50 objects). #' #' For BBURCG, the control parameter `"eps"` can be used to relax the problem by defining #' that a distance needs to be eps larger to count as a violation. This relaxation will improve the speed, #' but miss some Robinson events. The default value is 0. #' #' - **Genetic Algorithm:** `"GA"` #' #' The GA code has to be first registered. A detailed description can #' be found on the manual page for [register_GA()]. #' #' - **Quadratic assignment problem seriation:** #' `"QAP_LS"`, `"QAP_2SUM"`, `"QAP_BAR"`, `"QAP_Inertia"` (Hahsler, 2017) #' #' Formulates the seriation problem as a quadratic assignment problem and applies a #' simulated annealing solver to find a good solution. #' These methods minimize the #' **Linear Seriation Problem** (LS) formulation (Hubert and Schultz 1976), #' the **2-Sum Problem** formulation (Barnard, Pothen, and Simon 1993), the #' **banded anti-Robinson form** (BAR), or the **inertia criterion**. #' #' `control` parameters are passed on to [qap::qap()]. #' An important parameter is `rep` to return the best result from the #' given number of repetitions with random restarts. The default is 1, but bigger #' numbers result in better and more stable results. #' #' - **General Simulated Annealing:** `"GSA"` #' #' Implement simulated annealing similar to the ARSA method. However, it #' can optimize #' for any criterion measure defined in \pkg{seriation}. By default, the #' algorithm optimizes for the raw gradient measure, and is warm started with the #' result of spectral seriation (2-Sum problem) since Hahsler (2017) shows that #' 2-Sum solutions are similar to solutions for the gradient measure. #' Use `warmstart = "random"` for no warm start. #' #' The initial temperature `t0` and minimum temperature `tmin` can be set. If #' `t0` is not set, then it is estimated by sampling uphill moves and setting #' `t0` such that the median uphill move have a probability #' of `tinitialaccept`. #' Using the cooling rate `cool`, the number of iterations #' to go for `t0` to `tmin` is calculated. #' #' Several popular local neighborhood functions are #' provided, and new ones can be defined (see [LS]). Local moves are tried in each #' iteration `nlocal` times the number of objects. #' #' Note that this is an R implementation repeatedly calling the criterion funciton #' which is very slow. #' #' - **Stochastic gradient descent:** `"SGD"` #' #' Starts with a solution and then performs stochastic gradient descent to find #' a close-by local optimum given a specified criterion. #' #' Important `control` parameters: #' - `"criterion"`: the criterion to optimize #' - `"init"`: initial seriation (an order or the name of a seriation method) #' - `"max_iter"`: number of trials #' #' - **Spectral seriation:** `"Spectral"`, `"Spectral_norm"` (Ding and He, 2004) #' #' Spectral seriation uses a relaxation to minimize the **2-Sum Problem** #' (Barnard, Pothen, and Simon, 1993). It uses the order of the Fiedler vector #' of the similarity matrix's (normalized) Laplacian. #' #' Spectral seriation gives a good trade-off between seriation quality, #' and scalability (see Hahsler, 2017). #' #' - **Traveling salesperson problem solver:** `"TSP"` #' #' Uses a traveling salesperson problem solver to minimize the #' **Hamiltonian path length**. The solvers in \pkg{TSP} are used (see #' [TSP::solve_TSP()]). The solver method can be passed on via the `control` #' argument, e.g., `control = list(method = "two_opt")`. Default is the est #' of 10 runs of arbitrary insertion heuristic with 2-opt improvement. #' #' Since a tour returned by a TSP solver is a connected circle and we are #' looking for a path representing a linear order, we need to find the best #' cutting point. Climer and Zhang (2006) suggest adding a dummy city with #' equal distance to each other city before generating the tour. The place of #' this dummy city in an optimal tour with minimal length is the best cutting #' point (it lies between the most distant cities). #' #' #' **Other Methods** #' #' - **Identity permutation:** `"Identity" #' #' - **Reverse Identity permutation:** `"Reverse" #' #' - **Random permutation:** `"Random"` #' #' - **Rank-two ellipse seriation:** `"R2E"` (Chen 2002) #' #' Rank-two ellipse seriation starts with generating a sequence of correlation matrices #' \eqn{R^1, R^2, \ldots}. \eqn{R^1} is the correlation matrix of the original #' distance matrix \eqn{D} (supplied to the function as `x`), and #' \deqn{R^{n+1} = \phi R^n,} where \eqn{\phi} calculates the correlation #' matrix. #' #' The rank of the matrix \eqn{R^n} falls with increasing \eqn{n}. The first #' \eqn{R^n} in the sequence, which has a rank of 2 is found. Projecting all #' points in this matrix on the first two eigenvectors, all points fall on an #' ellipse. The order of the points on this ellipse is the resulting order. #' #' The ellipse can be cut at the two interception points (top or bottom) of the #' vertical axis with the ellipse. In this implementation, the topmost cutting #' point is used. #' #' - **Sorting Points Into Neighborhoods:** `"SPIN_STS"`, `"SPIN_NH"` (Tsafrir, 2005) #' #' Given a weight matrix \eqn{W}, the SPIN algorithms try to #' minimize the energy for a permutation (matrix \eqn{P}) given by \deqn{F(P) = #' tr(PDP^TW),} where \eqn{tr} denotes the matrix trace. #' #' `"SPIN_STS"` implements the Side-to-Side algorithm, which tries to push #' out large distance values. The default weight matrix suggested in the paper #' with \eqn{W=XX^T} and \eqn{X_i=i-(n+1)/2} is used. We run the algorithm form #' `step` (25) iteration and restart the algorithm `nstart` (10) with #' random initial permutations (default values in parentheses). #' #' `"SPIN_NH"` implements the neighborhood algorithm (concentrate low #' distance values around the diagonal) with a Gaussian weight matrix #' \eqn{W_{ij} = exp(-(i-j)^2/n\sigma)}, where \eqn{n} is the size of the #' dissimilarity matrix and \eqn{\sigma} is the variance around the diagonal #' that control the influence of global (large \eqn{\sigma}) or local (small #' \eqn{\sigma}) structure. #' #' We use the heuristic suggested in the paper for the linear assignment #' problem. We do not terminate as indicated in the algorithm but run all the #' iterations since the heuristic does not guarantee that the energy is #' strictly decreasing. We also implement the heuristic "annealing" scheme #' where \eqn{\sigma} is successively reduced. The parameters in `control` #' are `sigma` which can be a single value or a decreasing sequence #' (default: 20 to 1 in 10 steps), and `step`, which defines how many update #' steps are performed before for each value of `alpha`. Via #' `W_function` a custom function to create \eqn{W} with the function #' signature `function(n, sigma, verbose)` can be specified. #' #' - **Visual Assessment of (Clustering) Tendency:** `"VAT"` (Bezdek and Hathaway, 2002). #' #' Creates an order based on Prim's algorithm for finding a minimum spanning #' tree (MST) in a weighted connected graph representing the distance matrix. #' The order is given by the order in which the nodes (objects) are added to #' the MST. #' #' #' **Seriation methods for matrices (matrix)** #' #' Two-mode two-way data are general matrices. #' Some methods also require that the matrix is positive. #' Data frames and contingency tables ([base::table]) #' are converted into a matrix. However, the #' default methods are different. #' #' Some methods find the row and column order simultaneously, #' while others calculate them independently. #' Currently, the #' following methods are implemented for `matrix`: #' #' **Seriating rows and columns simultaneously** #' #' Row and column order influence each other. #' #' - **Bond Energy Algorithm:** `"BEA"` (McCormick, 1972). #' #' The algorithm tries to maximize a non-negative matrix's #' **Measure of Effectiveness.** #' Due to the definition of this measure, the tasks of #' ordering rows and columns are separable and can be solved independently. #' #' A row is arbitrarily placed; then, rows are positioned one by one. When this #' is completed, the columns are treated similarly. The overall procedure #' amounts to two approximate traveling salesperson problems (TSP), one on the #' rows and one on the columns. The so-called `best insertion strategy' is #' used: rows (or columns) are inserted into the current permuted list of rows #' (or columns). Several consecutive runs of the algorithm might improve the #' energy. #' #' Arabie and Hubert (1990) question its use with non-binary data if #' the objective is to find a seriation or one-dimensional orderings of rows #' and columns. #' #' Fionn Murtagh implemented the BEA code used in this package. #' #' - **TSP to optimize the Measure of Effectiveness**: `"BEA_TSP"` (Lenstra 1974). #' #' Distances between rows are calculated for a \eqn{M \times N} data matrix as #' \eqn{d_{jk} = - \sum_{i=1}^{i=M} x_{ij}x_{ik}\ (j,k=0,1,...,N)}. Distances #' between columns are calculated the same way from the transposed data matrix. #' #' Solving the two TSP using these distances optimizes the measure of #' effectiveness. BEA can be seen as a simple, suboptimal TSP method. #' #' `control` parameter: #' - `"method"`: a TSP solver method (see [TSP::solve_TSP()]). #' #' #' - **Correspondence analysis** `"CA"` #' #' This function is designed to help simplify a mosaic plot or other displays of a #' matrix of frequencies. It calculates a correspondence analysis of the matrix and #' an order for rows and columns according to the scores on a correspondence analysis dimension. #' #' This is the default method for contingency tables. #' #' `control` parameters: #' - `"dim"`: CA dimension used for reordering. #' - `"ca_param"`: List with parameters for the call to [ca::ca()]. #' #' **Seriating rows and columns separately using dissimilarities** #' #' - **Heatmap seriation:** `"Heatmap"` #' #' Calculates distances between #' rows and between columns and then applies seriation so each. This is #' the default method for data frames. #' #' `control` parameter: #' - `"seriation_method"`: a list with row and column seriation methods. #' The special method `"HC_Mean"` is available to use hierarchical clustering #' with reordering the leaves by the row/column means (see [stats::heatmap()]). #' Defaults to optimal leaf ordering `"OLO"`. #' - `"seriation_control"`: a list with control parameters for row and column #' seriation methods. #' - `"dist_fun"`: specify the distance calculation as a function. #' - `"scale"`: `"none"`, `"row"`, or `"col"`. #' #' #' **Seriate rows using the data matrix** #' #' These methods need access to the data matrix instead of dissimilarities to #' reorder objects (rows). Columns can also be reorderd by applying the same technique #' to the transposed data matrix. #' #' - **Order along the 1D locally linear embedding:** `"LLE"` #' #' Performs 1D the non-linear dimensionality reduction method locally linear embedding #' (see [lle()]). #' #' - **Order along the first principal component:** `"PCA"` #' #' Uses the projection of the data on its first principal component (using #' `stats::princomp()`) to #' determine the order of rows. Performs the same procedure on the transposed #' matrix to obtain the column order. #' #' Note that for a distance matrix calculated from `x` with Euclidean #' distance, this method minimizes the least square criterion. #' #' - **Angular order of the first two PCA components:** `"PCA_angle"` #' #' For rows, projects the data on the first two principal components #' and then orders by the angle in this space. The order is split by the larges #' gap between adjacent angles. A similar method was suggested by #' Friendly (2002) to order variables in correlation matrices #' by angles of first two eigenvectors. PCA also computes the eigenvectors #' of the covariance matrix of the data. #' #' Performs the same process on the #' transposed matrix for the column order. #' #' **Other methods** #' #' - **Angular order of the first two eigenvectors:** `"AOE"` (Friendly 2002) #' #' This method reordered correlation matrices by the angle in the space #' spanned by the two largest eigenvectors of the matrix. The order is split #' by the largest angle gap. This is the original method proposed by #' Friendly (2002). #' #' - **By row/column mean:** `"Mean"` #' #' A transformation can be applied before calculating the means. #' The function is specified as control #' parameter `"transformation"`. Any function that takes as an input a #' matrix and returns the transformed matrix can be used. Examples #' are `scale` or `\(x) x^.5`. #' #' #' - **Identity permutation:** `"Identity"` #' #' - **Reverse Identity permutation:** `"Reverse"` #' #' - **Random permutation:** `"Random"` #' #' For **general arrays** no built-in methods are currently available. #' #' @family seriation #' #' @param x the data. #' @param method a character string with the name of the seriation method #' (default: varies by data type). #' @param control a list of control options passed on to the seriation #' algorithm. #' @param margin an integer vector giving the margin indices (dimensions) to be #' seriated. For example, for a matrix, `1` indicates rows, `2` #' indicates columns, `c(1 ,2)` means rows and columns. #' Unseriated margins return the identity seriation order for that margin. #' @param rep number of random restarts for randomized methods. #' Uses [seriate_rep()]. #' @param ... further arguments are added to the `control` list. #' #' @return Returns an object of class [ser_permutation]. #' #' @author Michael Hahsler #' #' @references Arabie, P. and L.J. Hubert (1990): The bond energy algorithm #' revisited, _IEEE Transactions on Systems, Man, and Cybernetics,_ #' **20**(1), 268--274. #' \doi{10.1109/21.47829} #' #' Bar-Joseph, Z., E. D. Demaine, D. K. Gifford, and T. Jaakkola. (2001): Fast #' Optimal Leaf Ordering for Hierarchical Clustering. _Bioinformatics,_ #' **17**(1), 22--29. #' \doi{10.1093/bioinformatics/17.suppl_1.S22} #' #' Barnard, S. T., A. Pothen, and H. D. Simon (1993): A Spectral Algorithm for #' Envelope Reduction of Sparse Matrices. _In Proceedings of the 1993 #' ACM/IEEE Conference on Supercomputing,_ 493--502. Supercomputing '93. New #' York, NY, USA: ACM. \url{https://ieeexplore.ieee.org/document/1263497} #' #' Bezdek, J.C. and Hathaway, R.J. (2002): VAT: a tool for visual assessment of #' (cluster) tendency. _Proceedings of the 2002 International Joint #' Conference on Neural Networks (IJCNN '02),_ Volume: 3, 2225--2230. #' \doi{10.1109/IJCNN.2002.1007487} #' #' Brusco, M., Koehn, H.F., and Stahl, S. (2008): Heuristic Implementation of #' Dynamic Programming for Matrix Permutation Problems in Combinatorial Data #' Analysis. _Psychometrika,_ **73**(3), 503--522. #' \doi{10.1007/s11336-007-9049-5} #' #' Brusco, M., and Stahl, S. (2005): _Branch-and-Bound Applications in #' Combinatorial Data Analysis._ New York: Springer. #' \doi{10.1007/0-387-28810-4} #' #' Chen, C. H. (2002): Generalized Association Plots: Information Visualization #' via Iteratively Generated Correlation Matrices. _Statistica Sinica,_ #' **12**(1), 7--29. #' #' Ding, C. and Xiaofeng He (2004): Linearized cluster assignment via spectral #' ordering. _Proceedings of the Twenty-first International Conference on #' Machine learning (ICML '04)_. #' \doi{10.1145/1015330.1015407} #' #' Climer, S. and Xiongnu Zhang (2006): Rearrangement Clustering: Pitfalls, #' Remedies, and Applications, _Journal of Machine Learning Research,_ #' **7**(Jun), 919--943. #' #' D. Earle, C. B. Hurley (2015): Advances in dendrogram seriation #' for application to visualization. #' _Journal of Computational and Graphical Statistics,_ **24**(1), 1--25. #' #' Friendly, M. (2002): Corrgrams: Exploratory Displays for Correlation #' Matrices. _The American Statistician,_ **56**(4), 316--324. #' \doi{10.1198/000313002533} #' #' Gruvaeus, G. and Wainer, H. (1972): Two Additions to Hierarchical Cluster #' Analysis, _British Journal of Mathematical and Statistical Psychology,_ #' **25**, 200--206. #' \doi{10.1111/j.2044-8317.1972.tb00491.x} #' #' Hahsler, M. (2017): An experimental comparison of seriation methods for #' one-mode two-way data. _European Journal of Operational Research,_ #' **257**, 133--143. #' \doi{10.1016/j.ejor.2016.08.066} #' #' Hubert, Lawrence, and James Schultz (1976): Quadratic Assignment as a #' General Data Analysis Strategy. _British Journal of Mathematical and #' Statistical Psychology,_ **29**(2). Blackwell Publishing Ltd. 190--241. #' \doi{10.1111/j.2044-8317.1976.tb00714.x} #' #' Hurley, Catherine B. (2004): Clustering Visualizations of Multidimensional #' Data. _Journal of Computational and Graphical Statistics,_ #' **13**(4), 788--806. #' \doi{10.1198/106186004X12425} #' #' Kruskal, J.B. (1964). Nonmetric multidimensional scaling: a numerical method. #' _Psychometrika,_ **29**, 115--129. #' #' Lenstra, J.K (1974): Clustering a Data Array and the Traveling-Salesman #' Problem, _Operations Research,_ **22**(2) 413--414. #' \doi{10.1287/opre.22.2.413} #' #' Mair P., De Leeuw J. (2015). Unidimensional scaling. In _Wiley #' StatsRef: Statistics Reference Online,_ Wiley, New York. #' \doi{10.1002/9781118445112.stat06462.pub2} #' #' McCormick, W.T., P.J. Schweitzer and T.W. White (1972): Problem #' decomposition and data reorganization by a clustering technique, #' _Operations Research,_ **20**(5), 993--1009. #' \doi{10.1287/opre.20.5.993} #' #' Tenenbaum, J.B., de Silva, V. & Langford, J.C. (2000) #' A global network framework for nonlinear dimensionality reduction. #' _Science_ **290**, 2319-2323. #' #' Tsafrir, D., Tsafrir, I., Ein-Dor, L., Zuk, O., Notterman, D.A. and Domany, #' E. (2005): Sorting points into neighborhoods (SPIN): data analysis and #' visualization by ordering distance matrices, _Bioinformatics,_ #' **21**(10) 2301--8. #' \doi{10.1093/bioinformatics/bti329} #' #' Sammon, J. W. (1969) A non-linear mapping for data structure analysis. #' _IEEE Trans. Comput._, **C-18** 401--409. #' @keywords optimize cluster #' @examples #' # Show available seriation methods (for dist and matrix) #' list_seriation_methods() #' #' # show the description for ARSA #' get_seriation_method("dist", name = "ARSA") #' #' ### Seriate as distance matrix (for 50 flowers from the iris dataset) #' data("iris") #' x <- as.matrix(iris[-5]) #' x <- x[sample(nrow(x), size = 50), ] #' d <- dist(x) #' #' order <- seriate(d) #' order #' #' pimage(d, main = "Distances (Random Order)") #' pimage(d, order, main = "Distances (Reordered)") #' #' # Compare seriation quality #' rbind( #' random = criterion(d), #' reordered = criterion(d, order) #' ) #' #' # Reorder the distance matrix #' d_reordered <- permute(d, order) #' pimage(d_reordered, main = "Distances (Reordered)") #' #' #' ### Seriate a matrix (50 flowers from iris) #' #' # To make the variables comparable, we scale the data #' x <- scale(x, center = FALSE) #' #' # The iris flowers are ordered by species in the data set #' pimage(x, main = "original data", prop = FALSE) #' criterion(x) #' #' # Apply some methods #' order <- seriate(x, method = "BEA_TSP") #' pimage(x, order, main = "TSP to optimize ME", prop = FALSE) #' criterion(x, order) #' #' order <- seriate(x, method = "PCA") #' pimage(x, order, main = "First principal component", prop = FALSE) #' criterion(x, order) #' #' order <- seriate(x, method = "heatmap") #' pimage(x, order, main = "Heatmap seriation", prop = FALSE) #' criterion(x, order) #' #' # reorder the matrix #' x_reordered <- permute(x, order) #' #' # create a heatmap seriation manually by calculating #' # distances between rows and between columns #' order <- c( #' seriate(dist(x), method = "OLO"), #' seriate(dist(t(x)), method = "OLO") #' ) #' pimage(x, order, main = "Heatmap seriation", prop = FALSE) #' criterion(x, order) #' #' ### Seriate a correlation matrix #' corr <- cor(x) #' #' # plot in original order #' pimage(corr, main = "Correlation matrix") #' #' # reorder the correlation matrix using the angle of eigenvectors #' pimage(corr, order = "AOE", main = "Correlation matrix (AOE)") #' #' # we can also define a distance (we used d = sqrt(1 - r)) and #' # then reorder the matrix (rows and columns) using any seriation method. #' d <- as.dist(sqrt(1 - corr)) #' o <- seriate(d, method = "R2E") #' corr_reordered <- permute(corr, order = c(o, o)) #' pimage(corr_reordered, main = "Correlation matrix (R2E)") #' @export seriate <- function(x, ...) UseMethod("seriate") #' @export seriate.default <- function(x, ...) stop(gettextf("seriate not implemented for class '%s'.", class(x))) seriation/R/register_umap.R0000644000176200001440000001047114455314567015462 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2015 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. #' Register Seriation Based on 1D UMAP #' #' Use uniform manifold approximation and projection (UMAP) to embed the data #' on the number line and create a order for [seriate()]. #' #' Registers the method `"umap"` for [seriate()]. This method applies #' 1D UMAP to a data matrix or a distance matrix and extracts the order from #' the 1D embedding. #' #' Control parameter `n_epochs` can be increased to find a better embedding. #' #' The returned seriation permutation vector has an attribute named #' `embedding` containing the umap embedding. #' #' \bold{Note:} Package \pkg{umap} needs to be installed. #' #' @aliases register_umap umap #' @seealso [umap::umap()] in \pkg{umap}. #' @family seriation #' @returns Nothing. #' #' @references McInnes, L, Healy, J, UMAP: Uniform Manifold Approximation and #' Projection for Dimension Reduction, ArXiv e-prints 1802.03426, 2018 #' @keywords optimize cluster #' @examples #' #' \dontrun{ #' register_umap() #' #' ## distances #' get_seriation_method("dist", "umap") #' #' data(SupremeCourt) #' d <- as.dist(SupremeCourt) #' #' o <- seriate(d, method = "umap", verbose = TRUE) #' pimage(d, o) #' #' # look at the returned embedding and plot it #' attr(o[[1]], "configuration") #' plot_config(o) #' #' ## matrix #' get_seriation_method("matrix", "umap") #' #' data("Zoo") #' Zoo[,"legs"] <- (Zoo[,"legs"] > 0) #' x <- as.matrix(Zoo[,-17]) #' label <- rownames(Zoo) #' class <- Zoo$class #' #' o <- seriate(x, method = "umap", verbose = TRUE) #' pimage(x, o) #' #' plot_config(o[[1]], col = class) #' } #' @export register_umap <- function() { check_installed("umap") .contr <- unclass(umap::umap.defaults) .contr$n_epochs <- 1000 .contr$n_neighbors <- NA .contr$n_components <- 1 .contr$alpha <- 0.001 .contr$input <- NA .contr$random_state <- NA attr(.contr, "help") <- list(n_neighbors = "see ? umap::umap for help") umap_order <- function(x, control) { control <- .get_parameters(control, .contr) if (is.na(control$input)) control$input <- "dist" x <- as.matrix(x) # we cannot have more neighbors than data points if (is.na(control$n_neighbors)) control$n_neighbors <- 15 control$n_neighbors <- min(control$n_neighbors, nrow(x)) # use different random numbers for every run if (is.na(control$random_state)) control$random_state <- as.integer(runif(1, 0, .Machine$integer.max)) # has to be 1 control$n_components <- 1 class(control) <- class(umap::umap.defaults) embedding <- umap::umap(x, config = control) o <- order(embedding$layout) embedding <- drop(embedding$layout) names(embedding) <- rownames(x) attr(o, "configuration") <- embedding o } umap_order_matrix_2 <- function(x, control, margin = seq_along(dim(x))) { control$input <- "data" if (1L %in% margin) row <- umap_order(x, control) else row <- NA if (2L %in% margin) col <- umap_order(t(x), control) else col <- NA list(row, col) } set_seriation_method( "dist", "umap", umap_order, "Use 1D Uniform manifold approximation and projection (UMAP) embedding of the distances to create an order", .contr, randomized = TRUE, verbose = TRUE ) set_seriation_method( "matrix", "umap", umap_order_matrix_2, "Use 1D Uniform manifold approximation and projection (UMAP) embedding of the data to create an order", .contr, randomized = TRUE, verbose = TRUE ) } seriation/R/seriate_PCA.R0000644000176200001440000000643514457047715014740 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ## use the projection on the first principal component to determine the ## order .pca_contr <- list( center = TRUE, scale = FALSE, verbose = FALSE ) attr(.pca_contr, "help") <- list( center = "center the data (mean = 0)?", scale = "scale to unit variance?", verbose = FALSE ) seriate_matrix_fpc <- function(x, control = NULL, margin) { control <- .get_parameters(control, .pca_contr) center <- control$center scale <- control$scale verbose <- control$verbose o <- list(row = NA, col = NA) if (1L %in% margin) { pr <- stats::prcomp(x, center = center, scale. = scale, rank. = 1L) scores <- pr$x[, 1] os <- order(scores) o$row <- structure(os, names = rownames(x)[os], configuration = scores) if (verbose) cat("Rows: first PC explains", pr$sdev[1] / sum(pr$sdev) * 100, "%\n") } if (2L %in% margin) { x <- t(x) pr <- stats::prcomp(x, center = center, scale. = scale, rank. = 1L) scores <- pr$x[, 1] os <- order(scores) o$col <- structure(os, names = rownames(x)[os], configuration = scores) if (verbose) cat("Cols: first PC explains", pr$sdev[1] / sum(pr$sdev) * 100, "%\n") } if (verbose) cat("\n") o } seriate_matrix_angle <- function(x, control = NULL, margin) { control <- .get_parameters(control, .pca_contr) center <- control$center scale <- control$scale if (1L %in% margin) { pr <- prcomp(x, center = center, scale. = scale, rank = 2L) row <- .order_angle(pr$x[, 1:2]) names(row) <- rownames(x)[row] } else row <- NA if (2L %in% margin) { pr <- prcomp(t(x), center = center, scale. = scale, rank = 2L) col <- .order_angle(pr$x[, 1:2]) names(col) <- colnames(x)[col] } else col <- NA list(row = row, col = col) } set_seriation_method( "matrix", "PCA", seriate_matrix_fpc, "Uses the projection of the data on its first principal component to determine the order.", .pca_contr, optimizes = .opt(NA, "Least squares for each dimension (for Euclidean distances).") ) set_seriation_method( "matrix", "PCA_angle", seriate_matrix_angle, "Uses the angular order in the 2D PCA projection space split by the larges gap.", .pca_contr ) seriation/R/criterion.R0000644000176200001440000003563514607755374014627 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. #' Criterion for a Loss/Merit Function for Data Given a Permutation #' #' Compute the value for different loss functions \eqn{L} and merit function #' \eqn{M} for data given a permutation. #' #' **Criteria for distance matrices (dist)** #' #' For a symmetric dissimilarity matrix \eqn{D} with elements \eqn{d(i,j)} #' where \eqn{i, j = 1 \ldots n}, the aim is generally to place low distance #' values close to the diagonal. The following criteria to judge the quality of #' a certain permutation of the objects in a dissimilarity matrix are currently #' implemented (for a more detailed description and an experimental comparison #' see Hahsler (2017)): #' #' - **Gradient measures:** `"Gradient_raw"`, `"Gradient_weighted"` (Hubert et al, 2001) #' #' A symmetric dissimilarity matrix where the values in #' all rows and columns only increase when moving away from the main diagonal #' is called a perfect \emph{anti-Robinson matrix} (Robinson 1951). A suitable #' merit measure which quantifies the divergence of a matrix from the #' anti-Robinson form is #' \deqn{ M(D) = \sum_{i=1}^n \sum_{i y.} #' #' It results in raw number of triples satisfying the gradient constraints #' minus triples which violate the constraints. #' #' The second function is defined as: \deqn{f(z,y) = |y-z| sign(y-z) = y-z} It #' weights the each satisfaction or violation by the difference by its #' magnitude given by the absolute difference between the values. #' #' - **Anti-Robinson events:** `"AR_events"`, `"AR_deviations"` (Chen, 2002) #' #' `"AR_events"` counts the number of violations of the anti-Robinson form. #' \deqn{ L(D) = \sum_{i=1}^n \sum_{i d_{ik}) } #' #' where \eqn{m=(2/3-n)w + nw^2 - 2/3 w^3}, the maximal number of possible #' anti-Robinson events in the window. The window size \eqn{w} represents the #' number of neighboring objects (number of entries from the diagonal of the #' distance matrix) are considered. The window size is \eqn{2 \le w < n}, where #' smaller values result in focusing on the local structure while larger values #' look at the global structure. #' #' `...` parameters are: #' #' - `w` window size. Default is to use a `pct` of 100% of \eqn{n}. #' - `pct` and alternative specification of w as a percentage of \eqn{n} in \eqn{(0, 100]}. #' - `relative` logical; can be set to `FALSE` to get the GAR, i.e., the absolute number of AR #' events in the window. #' #' - **Banded anti-Robinson form criterion:** `"BAR"` (Earle and Hurley, 2015) #' #' Simplified measure for closeness to the anti-Robinson form in a band of size #' \eqn{b} with \eqn{1 <= b < n} around the diagonal. #' #' \deqn{ L(D) = \sum_{|i-j|<=b} (b+1-|i-j|) d_{ij} } #' #' For \eqn{b = 1} the measure reduces to the Hamiltonian path length. For #' \eqn{b = n-1} the measure is equivalent to ARc defined (Earle and Hurley, #' 2015). Note that ARc is equivalent to the Linear Seriation criterion (scaled #' by 1/2). #' #' `...` parameter is: `b` band size defaults to a band of 20% of \eqn{n}. #' #' - **Hamiltonian path length:** `"Path_length"` (Caraux and Pinloche, 2005) #' #' The order of the objects in a dissimilarity matrix corresponds to a path #' through a graph where each node represents an object and is visited exactly #' once, i.e., a Hamilton path. The length of the path is defined as the sum of #' the edge weights, i.e., dissimilarities. #' #' \deqn{L(D) = \sum_{i=1}^{n-1} d_{i,i+1}} #' #' The length of the Hamiltonian path is equal to the value of the minimal span #' loss function (as used by Chen 2002). Both notions are related to the #' \emph{traveling salesperson problem (TSP).} #' #' If `order` is not unique or there are non-finite distance values #' `NA` is returned. #' #' - **Lazy path length:** `"Lazy_path_length"` (Earl and Hurley, 2015) #' #' A weighted version of the Hamiltonian path criterion. This loss function #' postpones larger distances to later in the order (i.e., a lazy traveling #' sales person). #' #' \deqn{L(D) = \sum_{i=1}^{n-1} (n-i) d_{i,i+1}} #' #' Earl and Hurley (2015) proposed this criterion for reordering in #' visualizations to concentrate on closer objects first. #' #' - **Inertia criterion:** `"Inertia"` (Caraux and Pinloche, 2005) #' #' Measures the moment of the inertia of dissimilarity values around the #' diagonal as #' #' \deqn{M(D) = \sum_{i=1}^n \sum_{j=1}^n d(i,j)|i-j|^2} #' #' \eqn{|i-j|} is used as a measure for the distance to the diagonal and #' \eqn{d(i,j)} gives the weight. This criterion gives higher weight to values #' farther away from the diagonal. It increases with quality. #' #' - **Least squares criterion:** `"Least_squares"` (Caraux and Pinloche, 2005) #' #' The sum of squared differences between distances and the rank differences: #' \deqn{L(D) = \sum_{i=1}^n #' \sum_{j=1}^n (d(i,j) - |i-j|)^2,} where \eqn{d(i,j)} is an element of the #' dissimilarity matrix \eqn{D} and \eqn{|i-j|} is the rank difference between #' the objects. #' #' Note that if Euclidean distance is used to calculate \eqn{D} from a data #' matrix \eqn{X}, the order of the elements in \eqn{X} by projecting them on #' the first principal component of \eqn{X} minimizes this criterion. The #' least squares criterion is related to \emph{unidimensional scaling.} #' #' - **Linear Seriation Criterion:** `"LS"` (Hubert and Schultz, 1976) #' #' Weights the distances with the absolute rank differences. #' #' \deqn{L(D) \sum_{i,j=1}^n d(i,j) (-|i-j|)} #' #' - **2-Sum Criterion:** `"2SUM"` (Barnard, Pothen and Simon, 1993) #' #' The 2-Sum loss criterion multiplies the similarity between objects with the #' squared rank differences. #' #' \deqn{L(D) \sum_{i,j=1}^n 1/(1+d(i,j)) (i-j)^2,} #' #' where \eqn{s(i,j) = 1/(1+d(i,j))} represents the similarity between objects #' \eqn{i} and \eqn{j}. #' #' - **Absolute Spearman Correlation** `"Rho"` #' #' The absolute value of the Spearman rank correlation #' between the original distances and the rank differences in the order. # The absolute value is taken because a reverse order is equivalent. #' #' - **Matrix measures:** `"ME"`, `"Moore_stress"`, `"Neumann_stress"` #' #' These criteria are defined on general matrices (see #' below for definitions). The dissimilarity matrix is first converted into a #' similarity matrix using \eqn{S = 1/(1+D)}. If a different transformation is #' required, then perform the transformation first and supply a matrix instead #' of a dist object. #' #' **Criteria for matrices (matrix)** #' #' For a general matrix \eqn{X = x_{ij}}, \eqn{i = 1 \ldots n} and #' \eqn{j = 1 \ldots m}, currently the following loss/merit functions are implemented: #' #' - **Measure of Effectiveness:** `"ME"` (McCormick, 1972). #' #' The measure of effectiveness (ME) for matrix \eqn{X}, is defined as #' #' \deqn{M(X) = 1/2 \sum_{i=1}^{n} \sum_{j=1}^{m} #' x_{i,j}(x_{i,j-1}+x_{i,j+1}+x_{i-1,j}+x_{i+1,j})} #' #' with, by convention #' #' \deqn{x_{0,j}=x_{m+1,j}=x_{i,0}=x_{i,n+1}=0.} #' #' ME is a merit measure, i.e. a higher ME indicates a better arrangement. #' Maximizing ME is the objective of the bond energy algorithm (BEA). ME is not #' defined for matrices with negative values. `NA` is returned in this #' case. #' #' - **Weighted correlation coefficient:** `"Cor_R"` (Deutsch and Martin, 1971) #' #' Developed as the Measure of Effectiveness for the Moment #' Ordering Algorithm. #' R is a merit measure normalized so that its value always lies in #' \eqn{[-1,1]}. For the special case of a square matrix \eqn{R=1} corresponds #' to only the main diagonal being filled, \eqn{R=0} to a random distribution #' of value throughout the array, and \eqn{R=-1} to the opposite diagonal only #' being filled. #' #' - **Matrix Stress:** `"Moore_stress"`, `"Neumann_stress"` (Niermann, 2005) #' #' Stress measures the conciseness of the presentation of a matrix/table and #' can be seen as a purity function which compares the values in a matrix/table #' with its neighbors. The stress measure used here is computed as the sum of #' squared distances of each matrix entry from its adjacent entries. #' #' \deqn{ L(X) = \sum_{i=1}^n \sum_{j=1}^m \sigma_{ij} } #' #' The following types of neighborhoods are available: #' #' - Moore: comprises the eight adjacent entries. #' \deqn{ #' \sigma_{ij} = \sum_{k=\max(1,i-1)}^{\min(n,i+1)} #' \sum_{l=\max(1,j-1)}^{\min(m,j+1)} (x_{ij} - x_{kl})^2 } #' - Neumann: comprises the four adjacent entries. \deqn{ \sigma_{ij} = #' \sum_{k=\max(1,i-1)}^{\min(n,i+1)} (x_{ij} - x_{kj})^2 + #' \sum_{l=\max(1,j-1)}^{\min(m,j+1)} (x_{ij} - x_{il})^2 } #' #' The major difference between the Moore and the Neumann neighborhood is that #' for the later the contribution of row and column permutations to stress are #' independent and thus can be optimized independently. #' #' @family criterion #' #' @param x an object of class [dist] or a matrix (currently no functions #' are implemented for array). #' @param order an object of class [ser_permutation] suitable for #' `x`. If `NULL`, the identity permutation is used. #' @param method a character vector with the names of the criteria to be #' employed (see [list_criterion_methods()]), or `NULL` (default) in which case all available criteria are #' used. #' @param ... additional parameters passed on to the criterion method. #' @param force_loss logical; should merit function be converted into loss #' functions by multiplying with -1? #' @return A named vector of real values. #' @author Michael Hahsler #' @references Barnard, S.T., A. Pothen, and H. D. Simon (1993): A Spectral #' Algorithm for Envelope Reduction of Sparse Matrices. _In Proceedings of #' the 1993 ACM/IEEE Conference on Supercomputing,_ 493--502. Supercomputing #' '93. New York, NY, USA: ACM. #' #' Caraux, G. and S. Pinloche (2005): Permutmatrix: A Graphical Environment to #' Arrange Gene Expression Profiles in Optimal Linear Order, #' _Bioinformatics,_ **21**(7), 1280--1281. #' #' Chen, C.-H. (2002): Generalized association plots: Information visualization #' via iteratively generated correlation matrices, _Statistica Sinica,_ #' **12**(1), 7--29. #' #' Deutsch, S.B. and J.J. Martin (1971): An ordering algorithm for analysis of #' data arrays. _Operational Research,_ **19**(6), 1350--1362. #' \doi{10.1287/opre.19.6.1350} #' #' Earle, D. and C.B. Hurley (2015): Advances in Dendrogram Seriation for #' Application to Visualization. _Journal of Computational and Graphical #' Statistics,_ **24**(1), 1--25. #' \doi{10.1080/10618600.2013.874295} #' #' Hahsler, M. (2017): An experimental comparison of seriation methods for #' one-mode two-way data. _European Journal of Operational Research,_ #' **257**, 133--143. #' \doi{10.1016/j.ejor.2016.08.066} #' #' Hubert, L. and J. Schultz (1976): Quadratic Assignment as a General Data #' Analysis Strategy. _British Journal of Mathematical and Statistical #' Psychology,_ **29**(2). Blackwell Publishing Ltd. 190--241. #' \doi{10.1111/j.2044-8317.1976.tb00714.x} #' #' Hubert, L., P. Arabie, and J. Meulman (2001): _Combinatorial Data #' Analysis: Optimization by Dynamic Programming._ Society for Industrial #' Mathematics. #' \doi{10.1137/1.9780898718553} #' #' Niermann, S. (2005): Optimizing the Ordering of Tables With Evolutionary #' Computation, _The American Statistician,_ **59**(1), 41--46. #' \doi{10.1198/000313005X22770} #' #' McCormick, W.T., P.J. Schweitzer and T.W. White (1972): Problem #' decomposition and data reorganization by a clustering technique, #' _Operations Research,_ **20**(5), 993-1009. #' \doi{10.1287/opre.20.5.993} #' #' Robinson, W.S. (1951): A method for chronologically ordering archaeological #' deposits, _American Antiquity,_ **16**, 293--301. #' \doi{10.2307/276978} #' #' Tien, Y-J., Yun-Shien Lee, Han-Ming Wu and Chun-Houh Chen (2008): Methods #' for simultaneously identifying coherent local clusters with smooth global #' patterns in gene expression profiles, _BMC Bioinformatics,_ #' **9**(155), 1--16. #' \doi{10.1186/1471-2105-9-155} #' @keywords cluster #' @examples #' ## create random data and calculate distances #' m <- matrix(runif(20),ncol=2) #' d <- dist(m) #' #' ## get an order for rows (optimal for the least squares criterion) #' o <- seriate(d, method = "MDS") #' o #' #' ## compare the values for all available criteria #' rbind( #' unordered = criterion(d), #' ordered = criterion(d, o) #' ) #' #' ## compare RGAR by window size (from local to global) #' w <- 2:(nrow(m)-1) #' RGAR <- sapply(w, FUN = function (w) #' criterion(d, o, method="RGAR", w = w)) #' plot(w, RGAR, type = "b", ylim = c(0,1), #' xlab = "Windows size (w)", main = "RGAR by window size") #' @export criterion <- function(x, order = NULL, method = NULL, force_loss = FALSE, ...) UseMethod("criterion") seriation/R/lle.R0000644000176200001440000001075614453271332013364 0ustar liggesusers## lle is a simplified version from package lle ## by Holger Diedrich, Dr. Markus Abel #' Locally Linear Embedding (LLE) #' #' Performs the non linear dimensionality reduction method locally linear embedding #' proposed in Roweis and Saul (2000). #' #' #' LLE tries to find a lower-dimensional projection which preserves distances #' within local neighborhoods. This is done by (1) find for each object the #' k nearest neighbors, (2) construct the LLE weight matrix #' which represents each point as a linear combination of its neighborhood, and #' (2) perform partial eigenvalue decomposition to find the embedding. #' #' The `reg` parameter allows the decision between different regularization methods. #' As one step of the LLE algorithm, the inverse of the Gram-matrix \eqn{G\in R^{kxk}} #' has to be calculated. The rank of \eqn{G} equals \eqn{m} which is mostly smaller #' than \eqn{k} - this is why a regularization \eqn{G^{(i)}+r\cdot I} should be performed. #' The calculation of regularization parameter \eqn{r} can be done using different methods: #' #' - `reg = 1`: standardized sum of eigenvalues of \eqn{G} (Roweis and Saul; 2000) #' - `reg = 2` (default): trace of Gram-matrix divided by \eqn{k} (Grilli, 2007) #' - `reg = 3`: constant value 3*10e-3 #' #' @name lle #' @aliases lle LLE #' #' @param x a matrix. #' @param m dimensions of the desired embedding. #' @param k number of neighbors. #' @param reg regularization method. 1, 2 and 3, by default 2. See details. #' @returns a matrix of vector with the embedding. #' @author Michael Hahsler (based on code by Holger Diedrich and Markus Abel) #' @references #' Roweis, Sam T. and Saul, Lawrence K. (2000), Nonlinear Dimensionality #' Reduction by Locally Linear Embedding, #' _Science,_ **290**(5500), 2323--2326. \doi{10.1126/science.290.5500.2323} #' #' Grilli, Elisa (2007) Automated Local Linear Embedding with an application #' to microarray data, Dissertation thesis, University of Bologna. #' \doi{10.6092/unibo/amsdottorato/380} #' @keywords cluster manip #' @examples #' data(iris) #' x <- iris[, -5] #' #' # project iris on 2 dimensions #' conf <- lle(x, m = 2, k = 30) #' conf #' #' plot(conf, col = iris[, 5]) #' #' # project iris onto a single dimension #' conf <- lle(x, m = 1, k = 30) #' conf #' #' plot_config(conf, col = iris[, 5], labels = FALSE) #' @export lle <- function(x, m, k, reg = 2) { nns <- find_nn_k(x, k) #calculate weights res_wgts <- find_weights(nns, x, m, reg) wgts <- res_wgts$wgts #compute coordinates y <- find_coords(wgts, nns, N = dim(x)[1], n = dim(x)[2], m) y } find_coords <- function(wgts, nns, N, n, m) { W <- wgts M <- crossprod(diag(1, N) - W, diag(1, N) - W) eigen(M)$vectors[, c((N - m):(N - 1))] * sqrt(N) } find_weights <- function(nns, x, m, reg = 2) { N <- dim(x)[1] n <- dim(x)[2] wgts <- 0 * matrix(0, N, N) #intrinsic dim intr_dim <- c() for (i in (1:N)) { #number of neighbours k <- sum(nns[i, ]) #no neighbours (find_nn_k(k=0) or eps-neighbourhood) if (k == 0) next # calculate the differences between xi and its neighbours Z <- matrix(c(t(x)) - c(t(x[i, ])), nrow = nrow(x), byrow = TRUE) Z <- matrix(Z[nns[i, ], ], ncol = n, nrow = k) #gram-matrix G <- Z %*% t(Z) #regularisation delta <- 0.1 #calculate eigenvalues of G e <- eigen(G, symmetric = TRUE, only.values = TRUE)$values #skip if all EV are null if (all(e == 0)) next #choose regularisation method #see documentation if (reg == 1) { r <- delta * sum(utils::head(e, n - m)) / (n - m) } else if (reg == 2) { r <- delta ^ 2 / k * sum(diag(G)) } else r <- 3 * 10 ^ -3 #use regularization if more neighbors than dimensions! if (k > n) alpha <- r else alpha <- 0 #regularization G <- G + alpha * diag(1, k) #calculate weights #using pseudoinverse ginv(A): works better for bad conditioned systems if (k >= 2) wgts[i, nns[i, ]] <- t(MASS::ginv(G) %*% rep(1, k)) else wgts[i] <- G wgts[i, ] <- wgts[i, ] / sum(wgts[i, ]) } return(list( x = x, wgts = wgts )) } find_nn_k <- function(x, k) { nns <- as.matrix(dist(x)) nns <- t(apply(nns, 1, rank)) #choose the k+1 largest entries without the first (the data point itself) nns <= k + 1 & nns > 1 } seriation/R/Chameleon.R0000644000176200001440000000210214607571522014472 0ustar liggesusers#' 2D Data Sets used for the CHAMELEON Clustering Algorithm #' #' Several 2D data sets created to evaluate the CHAMELEON clustering algorithm in #' the paper by Karypis et al (1999). #' #' @name Chameleon #' @aliases Chameleon chameleon chameleon_ds4 chameleon_ds5 chameleon_ds7 #' chameleon_ds8 #' @docType data #' @family data #' @format #' `chameleon_ds4`: The format is a 8,000 x 2 data.frame. #' #' `chameleon_ds5`: The format is a 8,000 x 2 data.frame. #' #' `chameleon_ds7`: The format is a 10,000 x 2 data.frame. #' #' `chameleon_ds8`: The format is a 8,000 x 2 data.frame. #' @references Karypis, G., EH. Han, V. Kumar (1999): CHAMELEON: A Hierarchical #' Clustering Algorithm Using Dynamic Modeling, _IEEE Computer,_ #' **32**(8): 68--75. #' \doi{10.1109/2.781637} #' @keywords datasets #' @examples #' data(Chameleon) #' #' plot(chameleon_ds4, cex = .1) #' plot(chameleon_ds5, cex = .1) #' plot(chameleon_ds7, cex = .1) #' plot(chameleon_ds8, cex = .1) NULL # link does not work # @source The data was obtained from # \url{http://glaros.dtc.umn.edu/gkhome/cluto/cluto/download} seriation/R/robinson.R0000644000176200001440000001100514607605531014430 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. #' Create and Recognize Robinson and Pre-Robinson Matrices #' #' Provides functions to create and recognize (anti) Robinson and pre-Robinson #' matrices. A (anti) Robinson matrix has strictly decreasing (increasing) #' values when moving away from the main diagonal. A pre-Robinson matrix is a #' matrix which can be transformed into a perfect Robinson matrix using #' simultaneous permutations of rows and columns. #' #' Note that the default matrices are anti Robinson matrices. This is done #' because distance matrices (the default in R) are typically anti Robinson #' matrices with values increasing when moving away from the diagonal. #' #' Robinson matrices are recognized using the fact that they have zero anti #' Robinson events. For pre-Robinson matrices we use spectral seriation first #' since spectral seriation is guaranteed to perfectly reorder pre-Robinson #' matrices (see Laurent and Seminaroti, 2015). #' #' Random pre-Robinson matrices are generated by reversing the process of #' unidimensional scaling. We randomly (uniform distribution with range #' \eqn{[0,1]}) choose \eqn{x} coordinates for `n` points on a straight #' line and calculate the pairwise distances. For Robinson matrices, the points #' are sorted first according to \eqn{x}. For noise, \eqn{y} coordinates is #' added. The coordinates are chosen uniformly between 0 and `noise`, with #' \code{noise} between 0 and 1. #' #' @aliases Robinson robinson #' @family data #' @param x a symmetric, positive matrix or a dissimilarity matrix (a #' \code{dist} object). #' @param anti logical; check for anti Robinson structure? Note that for #' distances, anti Robinson structure is appropriate. #' @param pre logical; recognize/create pre-Robinson matrices. #' @param n number of objects. #' @param noise noise intensity between 0 and 1. Zero means no noise. Noise #' more than zero results in non-Robinson matrices. #' @return A single logical value. #' @references M. Laurent, M. Seminaroti (2015): The quadratic assignment #' problem is easy for Robinsonian matrices with Toeplitz structure, #' _Operations Research Letters_ **43**(1), 103--109. #' @examples #' ## create a perfect anti Robinson structure #' m <- random.robinson(10) #' pimage(m) #' #' is.robinson(m) #' #' ## permute the structure to make it not Robinsonian. However, #' ## it is still pre-Robinson. #' o <- sample(10) #' m2 <- permute(m, ser_permutation(o,o)) #' pimage(m2) #' #' is.robinson(m2) #' is.robinson(m2, pre = TRUE) #' #' ## create a binary random Robinson matrix (not anti Robinson) #' m3 <- random.robinson(10, anti = FALSE) > .7 #' pimage(m3) #' is.robinson(m3, anti = FALSE) #' #' ## create matrices with noise (as distance matrices) #' m4 <- as.dist(random.robinson(50, pre = FALSE, noise = .1)) #' pimage(m4) #' criterion(m4, method = "AR") #' #' m5 <- as.dist(random.robinson(50, pre = FALSE, noise = .5)) #' pimage(m5) #' criterion(m5, method = "AR") #' @export is.robinson <- function(x, anti = TRUE, pre = FALSE) { if (is.matrix(x) && !isSymmetric(unname(x))) stop("x needs to be a symmetric matrix!") d <- as.dist(x) if (!anti) d <- max(d) - d ## pre Robinson matrix can be perfectly seriated using ## spectral seriation! if (pre) d <- permute(d, seriate(d, method = "spectral")) unname(criterion(d, method = "AR_events") == 0) } #' @rdname is.robinson #' @export random.robinson <- function(n, anti = TRUE, pre = FALSE, noise = 0) { if (noise < 0 | noise > 1) stop("noise has to be beween 0 and 1.") x <- runif(n) if (!pre) x <- sort(x) if (noise) x <- cbind(x, runif(n, min = 0, max = noise)) m <- as.matrix(stats::dist(x)) if (!anti) m <- max(m) - m m } seriation/R/seriate_ARSA_Branch-Bound.R0000644000176200001440000001154514457047643017403 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ## Brusco: simulated annealing for the Linear Seriation Criterion .arsa_control <- list( cool = 0.5, ## Brusco: 0.95 tmin = 0.0001, ## Brusco: 0.0001 swap_to_inversion = .5, ## Brusco: .5 try_multiplier = 100, ## Brusco: 100 ### we do rep now for all # reps = 1L, ## Brusco: 20 verbose = FALSE ) attr(.arsa_control, "help") <- list( cool = "cooling factor (smaller means faster cooling)", tmin = "stopping temperature", swap_to_inversion = "probability for swap vs inversion local move", try_multiplier = "number of local move tries per object" ## Brusco: 100 # reps = "", ## Brusco: 20 ) seriate_dist_arsa <- function(x, control = NULL) { param <- .get_parameters(control, .arsa_control) A <- as.matrix(x) # SUBROUTINE arsa(N, A, COOL, TMIN, NREPS, IPERM, R1, R2, D, U, # S, T, SB, ZBEST, verbose) N <- ncol(A) if (N*N > .Machine$integer.max) stop("Long vectors not supported! Algorithm needs n^2 space.") #NREPS <- as.integer(param$reps) NREPS <- 1L IPERM <- integer(N) # R1 <- double(N*N/2) # R2 <- double(N*N/2) D <- double(N * N) U <- integer(N) S <- integer(N) T <- integer(NREPS * N) SB <- integer(N) ZBEST <- double(1) ret <- .Fortran( "arsa", N, A, as.numeric(param$cool), as.numeric(param$tmin), NREPS, IPERM, D, U, S, T, SB, ZBEST, as.numeric(param$swap_to_insertion), as.numeric(param$try_multiplier), as.integer(param$verbose), PACKAGE = "seriation" ) o <- ret[[6]] ### ARSA returns all 0's in some cases if (all(o == 0)) { o <- 1:N warning( "ARSA has returned an invalid permutation vector! Check the supplied dissimilarity matrix." ) } o } ## Brusco: branch-and-bound - unweighted row gradient .bb_rcgw_control <- list(verbose = FALSE) .bb_control <- list(eps = 0, verbose = FALSE) attr(.bb_control, "help") <- list( eps = "Distances need to be at least eps to count as violations" ) seriate_dist_bburcg <- function(x, control = NULL) { param <- .get_parameters(control, .bb_control) A <- as.matrix(x) N <- ncol(A) if (N*N*N > .Machine$integer.max) stop("Long vectors not supported! Algorithm needs n^3 space.") # SUBROUTINE bburcg(N, A, EPS, X, Q, D, DD, S, UNSEL, IVERB) X <- integer(N) Q <- integer(N) D <- integer(N * N * N) DD <- integer(N * N * N) S <- integer(N) UNSEL <- integer(N) ret <- .Fortran("bburcg", N, A, param$eps, X, Q, D, DD, S, UNSEL, param$verbose) o <- ret[[4]] o } ## Brusco: branch-and-bound - weighted row gradient seriate_dist_bbwrcg <- function(x, control = NULL) { param <- .get_parameters(control, .bb_rcgw_control) A <- as.matrix(x) N <- ncol(A) if (N*N*N > .Machine$integer.max) stop("Long vectors not supported! Algorithm needs n^3 space.") # SUBROUTINE bbwrcg(N, A, EPS, X, Q, D, DD, S, UNSEL, IVERB) X <- integer(N) Q <- integer(N) D <- double(N * N * N) DD <- double(N * N * N) S <- integer(N) UNSEL <- integer(N) ### eps is unused! ret <- .Fortran("bbwrcg", N, A, 0.0, X, Q, D, DD, S, UNSEL, param$verbose) o <- ret[[4]] o } set_seriation_method( "dist", "ARSA", seriate_dist_arsa, "Minimize the linear seriation criterion using simulated annealing (Brusco et al, 2008).", control = .arsa_control, randomized = TRUE, optimizes = .opt("LS", "Linear seriation criterion") ) set_seriation_method( "dist", "BBURCG", seriate_dist_bburcg, "Minimize the unweighted row/column gradient by branch-and-bound (Brusco and Stahl 2005). This is only feasible for a relatively small number of objects.", control = .bb_control, optimizes = .opt("Gradient_raw", "Unweighted gradient condition") ) set_seriation_method( "dist", "BBWRCG", seriate_dist_bbwrcg, "Minimize the weighted row/column gradient by branch-and-bound (Brusco and Stahl 2005). This is only feasible for a relatively small number of objects.", control = .bb_control, optimizes = .opt("Gradient_weighted", "Weighted gradient condition") ) seriation/R/AAA_color_palette.R0000644000176200001440000001211414607520363016076 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2011 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. #' Different Useful Color Palettes #' #' Defines several color palettes for [pimage()], [dissplot()] and #' [hmap()]. #' #' The color palettes are created with [colorspace::sequential_hcl()] and #' [colorspace::diverging_hcl()]. #' #' The two sequential palettes are: `reds()` and `grays()` (or #' `greys()`). #' #' The two diverging palettes are: `bluered()` and `greenred()`. #' #' @name palette #' @aliases palette, colors #' @family plots #' #' @param n number of different colors produces. #' @param power used to control how chroma and luminance is increased (1 = #' linear, 2 = quadratic, etc.) #' @param bias a positive number. Higher values give more widely spaced colors #' at the high end. #' @param ... further parameters are passed on to [sequential_hcl()] #' or [diverging_hcl()]. #' @return A vector with `n` colors. #' @author Michael Hahsler #' @keywords hplot #' @examples #' m <- outer(1:10,1:10) #' m #' #' pimage(m) #' pimage(m, col = greys(100, power = 2)) #' pimage(m, col = greys(100, bias = 2)) #' pimage(m, col = bluered(100)) #' pimage(m, col = bluered(100, power = .5)) #' pimage(m, col = bluered(100, bias = 2)) #' pimage(m - 25, col = greenred(20, bias = 2)) #' #' ## choose your own color palettes #' library(colorspace) #' hcl_palettes(plot = TRUE) #' #' ## blues (with 20 shades) #' pimage(m, #' col = colorspace::sequential_hcl(20, "Blues", rev = TRUE)) #' ## blue to green (aka "Cork") #' pimage(m, #' col = colorspace::diverging_hcl(100, "Cork")) #' @export bluered <- function(n = 100, bias = 1, power = 1, ...) grDevices::colorRampPalette(colorspace::diverging_hcl(n, palette = "Blue-Red", power = power, ...), bias = bias)(n) #hclplot(bluered(10)) #plot(1:20, col = bluered(20), pch = 19, cex = 4) #' @rdname palette #' @export greenred <- function(n = 100, bias = 1, power = 1, ...) grDevices::colorRampPalette(rev( colorspace::diverging_hcl(n, palette = "Red-Green", power = power, ...) ), bias = bias)(n) #hclplot(greenred(10)) #plot(1:20, col = greenred(20), pch = 19, cex = 4) #' @rdname palette #' @export reds <- function(n = 100, bias = 1, power = 1, ...) grDevices::colorRampPalette(rev( colorspace::sequential_hcl(n, palette = "Reds", power = power, ...) ), bias = bias)(n) #hclplot(reds(10)) #plot(1:20, col = reds(20), pch = 19, cex = 4) #' @rdname palette #' @export blues <- function(n = 100, bias = 1, power = 1, ...) grDevices::colorRampPalette(rev( colorspace::sequential_hcl(n, palette = "Blues 2", power = power, ...) ), bias = bias)(n) #hclplot(blues(10)) #plot(1:20, col = blues(20), pch = 19, cex = 4) #' @rdname palette #' @export greens <- function(n = 100, bias = 1, power = 1, ...) grDevices::colorRampPalette(rev( colorspace::sequential_hcl(n, palette = "Greens", power = power, ...) ), bias = bias)(n) #hclplot(greens(10)) #plot(1:20, col = greens(20), pch = 19, cex = 4) #' @rdname palette #' @export greys <- function(n = 100, bias = 1, power = 1, ...) grDevices::colorRampPalette(rev( colorspace::sequential_hcl(n, palette = "Grays", power = power, ...) ), bias = bias)(n) #hclplot(greys(10)) #plot(1:20, col = greys(20), pch = 19, cex = 4) #' @rdname palette #' @export grays <- greys .map_color_01 <- function(x, col) { x[] <- col[map_int(x, length(col), from.range = c(0, 1))] x } # translate all data to a color .map_color <- function(x, col, from.range = NA) { x[] <- col[map_int(x, length(col), from.range)] x } ## define default colors #.sequential_pal <- grays .sequential_pal <- blues .diverge_pal <- bluered ## define default ggplot2 colors .gg_logical_pal <- function() ggplot2::scale_fill_manual(values = c("white", "black"), na.value = "white") .gg_sequential_pal <- function(dist = FALSE, limits = NULL) { if (dist) ggplot2::scale_fill_gradient(low = scales::muted("blue"), high = "white", na.value = "white", limits = limits) else ggplot2::scale_fill_gradient(low = "white", high = scales::muted("blue"), na.value = "white", limits = limits) } .gg_diverge_pal <- function(limits = NULL) ggplot2::scale_fill_gradient2( low = scales::muted("blue"), mid = "white", high = scales::muted("red"), na.value = "white", midpoint = 0, limits = limits ) seriation/R/Wood.R0000644000176200001440000000204614607605460013515 0ustar liggesusers#' Gene Expression Data for Wood Formation in Poplar Trees #' #' A data matrix containing a sample of the normalized gene expression data for #' 6 locations in the stem of Popla trees published in the study by Herzberg et #' al (2001). The sample of 136 genes selected by Caraux and Pinloche (2005). #' #' @name Wood #' @family data #' @docType data #' @format The format is a 136 x 6 matrix. #' @references Hertzberg M., H. Aspeborg, J. Schrader, A. Andersson, #' R.Erlandsson, K. Blomqvist, R. Bhalerao, M. Uhlen, T. T. Teeri, J. #' Lundeberg, Bjoern Sundberg, P. Nilsson and Goeran Sandberg (2001): A #' transcriptional roadmap to wood formation, _PNAS,_ **98**(25), #' 14732--14737. #' #' Caraux G. and Pinloche S. (2005): PermutMatrix: a graphical environment to #' arrange gene expression profiles in optimal linear order, #' _Bioinformatics,_ **21**(7) 1280--1281. #' @source The data was obtained from #' \url{http://www.atgc-montpellier.fr/permutmatrix/manual/Exemples/Wood/Wood.htm}. #' @keywords datasets #' @examples #' data(Wood) #' head(Wood) NULL seriation/R/grid_helpers.R0000644000176200001440000001543114456072312015252 0ustar liggesusers####################################################################### # Basic Grid helpers # Copyright (C) 2011 Michael Hahsler # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. #' @import "grid" ## grid helpers ## requires map.R .grid_basic_layout <- function(main = "", left = unit(4, "lines"), right = unit(4, "lines"), top = unit(3, "lines"), bottom = unit(4, "lines"), gp = gpar()) { pushViewport(viewport( layout = grid.layout( nrow = 4, ncol = 3, widths = unit.c(left, # space unit(1, "npc") - left - right, # plot right), # space heights = unit.c( top, # title unit(1, "lines"), # space unit(1, "npc") - unit(1, "lines") - top - bottom, # plot bottom # space ) ), gp = gp )) pushViewport(viewport( layout.pos.col = 2, layout.pos.row = 1, name = "main" )) gp$cex <- 1.3 gp$fontface <- "bold" grid.text(main, gp = gp) upViewport(1) pushViewport(viewport( layout.pos.col = 2, layout.pos.row = 3, name = "plot" )) upViewport(2) } .grid_basic_layout_with_colorkey <- function(main = "", left = unit(4, "lines"), right = unit(0, "lines"), top = unit(3, "lines"), bottom = unit(4, "lines"), gp = gpar()) { pushViewport(viewport( layout = grid.layout( nrow = 4, ncol = 3, widths = unit.c(# space left, # plot unit(1, "npc") - left - right, # space right), heights = unit.c( # title top, # space unit(1, "lines"), # plot unit(1, "npc") - unit(1, "lines") - top - bottom, # space bottom ) ), gp = gp )) pushViewport(viewport( layout.pos.col = 2, layout.pos.row = 1, name = "main" )) gp$cex <- 1.3 gp$fontface <- "bold" grid.text(main, gp = gp) upViewport(1) pushViewport(viewport(layout.pos.col = 2, layout.pos.row = 3)) pushViewport(viewport(layout = grid.layout( 1, 3, widths = unit.c( # plot unit(1, "npc") - unit(8, "lines"), # space unit(1, "lines"), # colorkey unit(1, "lines") ), # plot heights = unit.c(unit(1, "npc")) ))) pushViewport(viewport( layout.pos.col = 1, layout.pos.row = 1, name = "plot" )) upViewport(1) pushViewport(viewport( layout.pos.col = 3, layout.pos.row = 1, name = "colorkey" )) upViewport(1) upViewport(2) } .grid_image <- function(x, zlim, col = grDevices::gray.colors(12), prop = FALSE, interpolate = FALSE, name = "image", gp = gpar()) { if (missing(zlim)) zlim <- range(x, na.rm = TRUE) else { # fix data for limits x[x < zlim[1]] <- NA x[x > zlim[2]] <- NA } ## create a viewport if (!prop) { vp <- viewport( #xscale = c(0,ncol(x)), yscale = c(nrow(x),0), xscale = c(0.5, ncol(x) + .5), yscale = c(nrow(x) + .5, 0.5), default.units = "native", name = name ) pushViewport(vp) } else{ ## ratio if (nrow(x) > ncol(x)) { w <- ncol(x) / nrow(x) h <- 1 } else if (nrow(x) < ncol(x)) { h <- nrow(x) / ncol(x) w <- 1 } else { w <- 1 h <- 1 } vp <- viewport( xscale = c(0.5, ncol(x) + .5), yscale = c(nrow(x) + .5, 0.5), width = unit(w, "snpc"), height = unit(h, "snpc"), default.units = "native", name = name ) pushViewport(vp) } grid.raster( .map_color(x, col, zlim), interpolate = interpolate, default.units = "npc", width = 1, height = 1 ) ## make border gp_border <- gp gp_border$fill <- "transparent" grid.rect(gp = gp_border) upViewport(1) } .grid_barplot_horiz <- function(height, name = "barplot", xlab = "", gp = gpar(), gp_bars = gpar(fill = "lightgrey")) { n <- length(height) ## these plots always start at x = 0 or below! lim <- c(min(c(height, 0)), max(height)) ## create a viewport vp <- viewport( xscale = lim , yscale = c(n, 0), default.units = "native", name = name, gp = gp ) pushViewport(vp) grid.rect( x = 0, y = (1:n) - .5, width = height, height = 1, just = c("left", "center"), default.units = "native", gp = gp_bars ) ## hopefully there is space outside for axes grid.xaxis() grid.text(xlab, y = unit(-3, "lines")) upViewport(1) } .grid_colorkey <- function(range, col, threshold = NULL, lab = "", name = "colorkey", horizontal = TRUE, gp = gpar()) { ### no color key for only a single value if (diff(range) == 0) { vp <- viewport( xscale = c(0, 1), yscale = c(0, 1), default.units = "native", name = name ) pushViewport(vp) grid.text( label = range[1], x = 0.5, y = 0.5, default.units = "native" ) upViewport(1) return() } if (horizontal) vp <- viewport( xscale = range, yscale = c(0, 1), default.units = "native", name = name ) else vp <- viewport( xscale = c(0, 1), yscale = range, default.units = "native", name = name ) pushViewport(vp) n <- length(col) #width <- diff(range)/n #xs <- seq(range[1] + width/2, range[2] - width/2, length.out = n) xs <- seq(range[1], range[2], length.out = n) ## do not display the part above the threshold col[xs > threshold] <- NA ## col if (horizontal) grid.raster(t(col), width = 1, height = 1, interpolate = FALSE) else grid.raster(rev(col), width = 1, height = 1, interpolate = FALSE) #gp_col <- gp #gp_col$col <- 0 #gp_col$fill <- col #grid.rect(x = xs, y = 0, width = width, height = 1, # just = c("centre", "bottom"), default.units = "native", # gp = gp_col) ## box gp_border <- gp gp_border$fill <- "transparent" grid.rect(gp = gp_border) if (horizontal) grid.xaxis(gp = gp) else grid.yaxis(main = FALSE, gp = gp) if (horizontal) grid.text(lab, y = unit(-2.5, "lines")) else grid.text(lab, x = unit(4, "lines"), rot = 90) upViewport(1) } seriation/R/register_DendSer.R0000644000176200001440000001607314607606255016045 0ustar liggesusers####################################################################### # seriation - Infrastructure for seriation # Copyright (C) 2015 Michael Hahsler, Christian Buchta and Kurt Hornik # # 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 2 of the License, or # 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, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. #' Register Seriation Methods from Package DendSer #' #' Register the DendSer dendrogram seriation method and the ARc criterion #' (Earle and Hurley, 2015) for use with [seriate()]. #' #' Registers the method `"DendSer"` for seriate. DendSer is a fast #' heuristic for reordering dendrograms developed by Earle and Hurley (2015) #' able to use different criteria. #' #' `control` for [`seriate()`] with #' method `"DendSer"` accepts the following parameters: #' #' - `"h"` or `"method"`: A dendrogram or a method for hierarchical clustering #' (see [hclust]). Default: complete-link. #' - `"criterion"`: A seriation criterion to optimize (see #' `list_criterion_methods("dist")`. Default: `"BAR"` (Banded #' anti-Robinson from with 20% band width). #' - `"verbose"`: a logical; print progress information? #' - `"DendSer_args"`: additional arguments for [`DendSer::DendSer()`]. #' #' For convenience, the following methods (for different cost functions) are #' also provided: #' #' - `"DendSer_ARc"` (anti-robinson form), #' - `"DendSer_BAR"` (banded anti-Robinson form), #' - `"DendSer_LPL"` (lazy path length), #' - `"DendSer_PL"` (path length). #' #' **Note:** Package \pkg{DendSer} needs to be installed. #' #' @aliases register_DendSer DendSer dendser #' @seealso [`DendSer::DendSer()`] #' @family seriation #' @returns Nothing. #' #' @author Michael Hahsler based on code by Catherine B. Hurley and Denise #' Earle #' @references D. Earle, C. B. Hurley (2015): Advances in dendrogram seriation #' for application to visualization. _Journal of Computational and #' Graphical Statistics,_ **24**(1), 1--25. #' @keywords optimize cluster #' @examples #' #' \dontrun{ #' register_DendSer() #' get_seriation_method("dist", "DendSer") #' #' d <- dist(random.robinson(20, pre=TRUE)) #' #' ## use Banded AR form with default clustering (complete-link) #' o <- seriate(d, "DendSer_BAR") #' pimage(d, o) #' #' ## use different hclust method (Ward) and AR as the cost function for #' ## dendrogram reordering #' o <- seriate(d, "DendSer", control = list(method = "ward.D2", criterion = "AR")) #' pimage(d, o) #' } #' #' @export register_DendSer <- function() { check_installed("DendSer") ## seriation methods ## control: # cost (default: costBAR) # ## costLS, costPL, costLPL, costED, costARc, costBAR # h (default is NULL -> complete) .DendSer_control <- structure( list( h = NULL, method = "complete", criterion = NULL, DendSer_args = NULL, verbose = FALSE ), help = list( h = "an hclust object (optional)", method = "hclust linkage method", criterion = "criterion to optimize the dendrogram for", DendSer_args = "more arguments are passed on to DendSer (? DendSer)" ) ) DendSer_helper <- function(x, control) { n <- attr(x, "Size") control <- .get_parameters(control, .DendSer_control) control$cost <- DendSer::crit2cost(crit = control$criterion) control$criterion <- NULL ## produce hclust if (is.null(control$h)) control$h <- hclust(x, control$method) control$method <- NULL control$ser_weight <- x if (!is.null(control$DendSer_args)) { control <- c(control, control$DendSer_args) control$DendSer_args <- NULL } permute(control$h, do.call(DendSer::DendSer, control)) } DendSer_BAR <- function(x, control) { control$criterion <- "BAR" DendSer_helper(x, control) } DendSer_PL <- function(x, control) { control$criterion <- "Path_length" DendSer_helper(x, control) } DendSer_LPL <- function(x, control) { control$criterion <- "Lazy_path_length" DendSer_helper(x, control) } DendSer_ARc <- function(x, control) { control$criterion <- "Arc" DendSer_helper(x, control) } ## This is not Least Squares! # DendSer_LS <- function(x, control) { # control$cost <- DendSer::costLS # control$criterion <- "LS" # control$h <- hclust(x) # DendSer_helper(as.matrix(x)[,1], control) # } set_seriation_method( "dist", "DendSer", DendSer_BAR, "Dendrogram seriation (Earle and Hurley, 2015).", .DendSer_control, optimizes = .opt(NA, "specified criterion restricted by dendrogram"), verbose = TRUE ) set_seriation_method( "dist", "DendSer_BAR", DendSer_BAR, "Dendrogram seriation with BAR (Earle and Hurley, 2015).", .DendSer_control, optimizes = .opt("BAR", "banded anti-Robinson form restricted by dendrogram"), verbose = TRUE ) set_seriation_method( "dist", "DendSer_PL", DendSer_PL, "Dendrogram seriation (Path length)", .DendSer_control, optimizes = .opt("Path_length", "restricted by dendrogram"), verbose = TRUE ) set_seriation_method( "dist", "DendSer_LPL", DendSer_LPL, "Dendrogram seriation (Lazy path length)", .DendSer_control, optimizes = .opt("Path_length", "restricted by dendrogram"), verbose = TRUE ) set_seriation_method( "dist", "DendSer_ARc", DendSer_ARc, "Dendrogram seriation (Anti-Robinson form cost)", optimizes = .opt("ARc", "Anti-Robinson form cost restricted by dendrogram"), .DendSer_control, verbose = TRUE ) # set_seriation_method("dist", "DendSer_LS", # DendSer_LS, "Dendrogram seriation (Leaf sort)") ## criteria DendSer_crit_ARc <- function(x, order, ...) { x <- as.matrix(x) if (is.null(order)) order <- 1:nrow(x) else order <- get_order(order) DendSer::costARc(x, order, ...) } set_criterion_method("dist", "ARc", DendSer_crit_ARc, "Anti-Robinson form cost", FALSE, verbose = TRUE) ## Already in seriation # DendSer_crit_BAR <- function(x, order, ...) { # x <- as.matrix(x) # if (is.null(order)) order <- 1:nrow(x) # else order <- get_order(order) # DendSer::costBAR(x,order,...) # } # # set_criterion_method("dist", "BAR", DendSer_crit_BAR, # "Banded AR cost", FALSE) # criterion_method_dist_LPL <- function(x, order, ...) { # x <- as.matrix(x) # if (is.null(order)) order <- 1:nrow(x) # else order <- get_order(order) # DendSer::costLPL(x,order,...) # } # # set_criterion_method("dist", "LPL", criterion_method_dist_LPL, # "Lazy path cost", FALSE) #} } seriation/NEWS.md0000644000176200001440000003735414610040003013345 0ustar liggesusers# seriation 1.5.5 (04/17/2024) - Updated man pages. # seriation 1.5.4 (12/11/2023) ## Bug Fixes - Fixed MDS_angle order for different BLAS implementation giving different results for eigen(). # seriation 1.5.3 (11/28/2023) ## New Features - permute for dendrograms gained parameter dist and accepts now seriation methods. - Added method "AOE" for correlation matrices. - registry for seriation methods now contains the name of the seriation criterion and a description. seriate_rep now automatically uses the criterion from the registry. - all seriation methods gained parameter rep. ## Bug Fixes - optimal.c: use now the correct data type for Rprintf - Skip deterministic tests on Mac M1 because of numerical differences. # seriation 1.5.1 (07/20/2023) ## New Fearures - pimage and permute now accept order = TRUE to perform the default seriation. - hmap gained parameter col_dist to define the color palette used for distance matrices. - hmap dropped parameter showDend and gained parameter plot_margins instead. ## Bug Fixes - pimage/ggpimage now use zlim correctly to choose the color palette. - BEA for matrix is now correctly registered as randomized. - fixed col/row_labels parameter. - rev() for seriations based on hclust now reverses the dendrogram. - tests now also accept reverse orders for testing deterministic methods. # seriation 1.5.0 (07/19/2023) ## New Features - The seriation registry now contains help information for the seriation method parameters. - New function seriate_best, seriate_rep, and seriate_improve() to easily find a good order for randomized algorithms. Parallel execution is supported. - Seriation method registry has new fields 'randomized' to indicate if an algorithm is randomized and can be run several times and 'optimizes' to indicate what criterion is optimized. This information is used by seriate_rep. - Seriation for arrays (including matrix) gained margin parameter. - tsne and umap can now be used on data matrices. - get_rank() returns now labels. - Embedding-based methods now return the order with an attribute called configuration. - New MDS_stress() function. - Added register_smacof(). - Added seriation method "Reverse" for dist. - New seriation methods from vegan: isomap, monoMDS, metaMDS. - New seriation method "Enumerate" for complete enumeration. - New seriation method "Mean" for matrix. - New seriation method "SGD" for distances to improve solutions using stochastic gradient descent. - New seriation method "LLE" (locally linear embedding) for matrix. - Heatmap seriation has now special seriation_method "HC_Mean". - New seriation criterion "Rho" calculates the absolute Spearman's rank correlation coefficient. - list_seriation_methods() and list_criterion_methods() gained parameter names_only. ## Changes - Seriation methods for MDS are now MDS, isoMDS and Sammon_mapping and have now individual control parameters. - orderplot() is now called plot_config() and can also visualize 2D configurations. - HC-based seriation: The control parameter method is now linkage so it can be used in seriate() in the ... - Seriation method spectral now also returns the embedding. - Seriation method simulated annealing is now called "GSA". - Simplified generics for pimage and ggpimage. Defaults for pimage.dist have changed. - DendSer methods now return hclust objects. ## Bug Fixes - fixed labels returned by uniscale() - FORTRAN: replaced old DFLOAT with DBLE (reported by Brian D. Ripley). # seriation 1.4.2 (03/07/2023) ## Bug Fixes - pimage: ... is now passed on to the seriation method. - added missing S3 method registrations. ## New Features - methods umap and tsne can now return the embedding. # seriation 1.4.1 (12/27/2022) ## New Features - get_order not consistently returns permutation vectors with names (by david-barnett). ## Bug Fixes - criterion.c: replaced enum for bool with - Additional contributors are not in alphabetical order. # seriation 1.4.0 (10/21/2022) ## New Features - seriate for arrays (including matrices) now returns a complete ser_permutation for all dimensions even if margins are specified. For not specified margins, identity permutations are returned. - added support for tables. - added new seriation method CA (correspondence analysis) contributed by Michael Friendly. - permute now accepts more than one margin. - permute now accepts a seriation method instead of order. ## Bug Fixes - seriate.dist now throws correct error upon encountering NAs (by david-barnett) # seriation 1.3.6 (07/14/2022) ## New Features - ggpimage has now a zlim parameter. ## Bug Fixes - added register functions back to export (reported by thomasp85). - fixed viewports for pimage with colorkey. - fixed ggplot diverging color palette direction. # seriation 1.3.4 (3/16/2022) ## Bug Fixes - fixed length calculation in optimal.c # seriation 1.3.3 (3/3/2022) ## New Features - pimage and dissplot gained parameter diag. pimage for dist by default does not show the diagonal now. - C code now supports long vectors for dist objects. ## User-Visible Changes - removed deprecated show functions for the registries. ## Internal Changes - we now use roxygen for documentation. - added check for long vectors that FORTRAN cannot handle. # seriation 1.3-2 (2/10/2022) ## Changes - improved argument checking for ser_permutation_vector(). - ggplot uses now standard ggplot2 color palettes. # seriation 1.3-1 (10/15/2021) ## New Features - added seriation based on 1D t-SNE embedding. - added seriation based on 1D UMAP embedding. - added seriation based on OPTICS. ## User-Visible Changes - VAT plots now default to upper_tri = TRUE to show the whole matrix. # seriation 1.3-0 (06/29/2021) ## User-Visible Changes - Plotting - Most plotting functions have now a common interface. This changed many parameters. - hmap now uses heatmap from package stats. - dissplot shows now averages in the top triangles. - improved layout (less white space) for grid-based plots. - Registry - list_seriation_methods and list_criterion_methods without kind return now a list. - show_seriation_methods and show_criterion_methods are deprecated - Other Changes - criterion returns now NA with a warning for ME for non-positive matrices (used to stop with an error). - dependency dendextend is now only suggested (used for testing). - get_order now returns also labels. - hclust-based seriations now defaults for linkage to complete instead of average. ## New Features - Plotting - Major refactoring of plotting functions to provide a more consistent interface. - added ggplot2-based plots, ggimage, gghmap, ggVAT, ggiVAT, ggbertinplot, ggdissplot. - colors are now more consistent and all have bias and power. - Seriation methods - seriate for matrix has now method "Heatmap". - seriate now accepts data.frames and used method "heatmap" as the default. - added seriation method "Reverse" for reverse identity order. - Permutation - permute for matrix-like objects gained parameter margin. - permute for data.frame works now identical to permute for matrix. # seriation 1.2-9 (09/29/2020) - removed dependency on methods. - added DOIs. # seriation 1.2-8 (08/27/2019) ## New features - get_seriation_method now has better information and also show available control parameters. ## Bug Fixes - GA: Updated parameter names after change in package ga. # seriation 1.2-7 (06/07/2019) ## Bug Fixes - Added missing void \* to init.c # seriation 1.2-6 (06/03/2019) ## Bug Fixes - Converted print routines in FORTRAN code to dblepr, intpr, etc. - seriate.matrix also prints now method name for control verbose = TRUE. # seriation 1.2-5 (05/30/2019) ## Bug Fixes - Fixed compilation warnings in FORTRAN code. # seriation 1.2-4 (05/29/2019) ## New features - bertinplot: panel colors can now be specified in highlight and as shading.function. ## Bug Fixes - bertinplot: fix white squares when frame = TRUE (by Dirk Seidensticker). - seriation method "BEA" has now a slight code improvement (suggested by RichardKav) # seriation 1.2-3 (02/05/2018) ## Bug Fixes - seriation method "BEA" is now not longer masked by "BEA_TSP". Also the FORTRAN calls now work. - SPIN: making the matrix doubly stochastic now checks all rows/columns (reported and fixed by cerebis) # seriation 1.2-2 (05/08/2017) ## New features - Added new seriation method SA which provides simulated annealing for all criterion measures. - Added criterion Cor_R (ME for the moment ordering algorithm by Deutsch and Martin). - Added uniscale to produce a unidimensional scaling configuration given a distance matrix and a permutation. - Criterion gained parameter force_loss (default is FALSE). Merit measures are converted into loss values by multiplying with -1. - Added Supreme Court dataset. ## Changes and Bug Fixes - Default for seriate (dist) and dissplot is now "Spectral" since it gives a better tradeoff between quality and speed. - Seriation method ARSA's control argument nreps is now for consistency called reps. - Criterion: dist objects are now automatically converted into a similarity matrix for ME, Moore_stress and Neumann_stress. - pimage now suppresses the color key for logical matrices and checks for all NAs and infinite entries. - Correction: ARSA minimizes the linear seriation criterion (man page and vignette). # seriation 1.2-1 (08/06/2016) ## New features - Added new distance measure called absolute pairwise rank differences. ## Changes and Bug Fixes - The default setting for ser_dist and ser_cor is now reverse is TRUE. - pimage does now work with matrices containing only a single value. - control parameters for method TSP are now correctly passed on (reported by David Aliyev). # seriation 1.2-0 (2/22/2016) ## New features - RGAR gained parameter pct to specify the window as a percentage. - Added the lazy path length criterion. - Added the banded anti-Robinson form (BAR) criterion. - Added QAP_Inertia and QAP_BAR solver. - Added DendSer using register_DendSer(). - Added GA using register_GA(). ## Changes and Bug Fixes - Fixed RGAR (w needs to be in [2,n-1]). - Registry now warns and modifies entries with the same name. - Registry now lists methods in alphabetical order. - Seriation method alias Chen was removed. Use R2E. # seriation 1.1-3 (12/18/2015) - Added is.robinson to recognize (pre) Robinson matrices. - Added random.robinson to create random Robinson matrices. - Added seriation methods "QAP_LS" and "QAP_2SUM" (QAP-based seriation). - Added criteria "LS" and "2SUM" from QAP-based seriation. - Fixed Spectral_norm seriation. - hmap now honors zlim also in dendrogram-based maps. - hmap gained option sym for seriation based maps. showdist can now be one of "none" (default), "row", "column", or "both". - ser_cor and ser_dist gained parameter y. ser_cor gained parameter test to perform tests for association. - Added permute method for hclust and dendrogram objects. # seriation 1.1-2 (8/23/2015) - Argument (control and ...) check warns now instead of throwing an error. - seriation_dist, seriation_cor and seriation_align are now shortened to ser_dist, ser_cor and ser_align. - Method "ppc" is now faster and also available in ser_cor. - Fixed ser_cor for "spearman" and "Kendall" (uses now rank correctly). - ser_cor and ser_dist gained parameter reverse to indicate that permuations are also tried in reverse and the best value is reported. # seriation 1.1-1 (7/1/2015) - get_permutation_matrix added. - seriation_dist measure "ppc" (positional proximity coefficient) added. - Fixed bug with permute and ser_permutation_vectors. - Identity permutations (NA) give now an error for get_order and get_permutation_matrix. - Fixed imports for non-base R packages. # seriation 1.1-0 (06/09/2015) - Seriation method 'Identity' added. - Seriation method 'Random' added. - Seriation method 'VAT' added. - Seriation methods 'Spectral' and 'Spectral_norm' added. - Seriation methods 'PCA_angle' and 'MDS_angle' added. - Seriation methods 'SPIN_NH' and 'SPIN_STS' added. - Several aliases for seriation methods added. - Criterion 'RWGAR' added. - permutation_matrix2vector and permutation_vector2matrix added. - Identity permutation (value NA) added. - ser_permutation and ser_permutation_vector can now be used interchangeably, - get_rank for permutation vectors added. - seriation_dist and seriation_alignment to calculate dissimilarities between seriation orders added. - Wood data set added. - # Chameleon data sets added. - create_lines_data, create_ordered_data added. - pimage, hmap and dissplot: Simplified and made interfaces more consistent (all use now zlim, consistent default color palettes). - pimage gained axes and prop; NA in matrix now works. - seriation checks now control arguments consistently. - We use now package registry to manage methods. - reorder for hclust added. - iVAT with path distance added. - color palettes (bluered, greenred, grays) added. - Improved speed of C code. - Problem with testthat file names fixed. - bburg.f/bbwrg.f: memory access problem fixed. # seriation 1.0-14 (12/02/2014) - arsa.f: removed 0 flag in rand() so it compiles under AIX (reported by Lei Zhang) - arsa.f/bburg.f/bbwrg.f: calls now R RNG to be compatible with certain compilers (e.g., Intel FORTRAN) (reported by Rohan Shah) # seriation 1.0-13 (3/11/2014) - Fixed dependence on MASS # seriation 1.0-12 (2/18/2014) - ser_permutation_vectors can now be reversed with rev - get_order: removed the weird labels. - we use now testthat - fixed bug with intra-cluster ordering using silhouette width (reported by Bettina Gruen) - Cleaned up dependencies: TSP, grid, cluster, gclus and colorspace are now imports instead of dependencies. # seriation 1.0-11 (9/6/2013) - service release. # seriation 1.0-10 (2/15/2013) - pimage has now a colorkey and a range argument - fixed bug in ARSA when the distance matrix contains all 0s - added PACKAGE argument to .Fortran calls # seriation 1.0-8 and 1.0-9 (11/6/2012) - get_order: labels are now in the correct order (Bug report by Crt Ahlin) - Replaced FORTRAN I/O with R I/O for verb=TRUE - Fixed pop/newpage bug in pimage.dist (reported by Bettina Gruen) # seriation 1.0-7 (9/25/2012) - Fixed out-of-bounds bug in arsa.f (reported by Rohan Shah) - Fixed out-of-bounds bug in bburcg.f # seriation 1.0-6 (10/19/2011) - removed deprecated parameter gamma for dissplot() # seriation 1.0-5 (9/2/2011) - bertinplot(): fixed representation for 0, neg. values and highlight. (Bug report by G. Sawitzki). - bertinplot(): added panel.blocks and option for shading - bertinplot(): added bertin_cut_line() # seriation 1.0-4 (6/28/2011) - pimage() now uses grid.raster. - dissplot() now uses grid.raster. # seriation 1.0-3 (1/14/2011) - improved validity check for permutations and added check for dist with neg. entries to seriate.dist. # seriation 1.0-2 (3/13/2010) - service release # seriation 1.0-1 (8/25/2009) - added drop=FALSE in permute for matrix. - fixed reordering for labels. - added permute for character. - added different methods to calculate between cluster dissimilarities (min, max, avg, Hausdorff). - dissplot has now additional options hue, power, gamma, flip and changed behavior for averages. dissplot depends now on colorspace. # Version 1.0-0 (3/24/2009) - many changes and first stable release. # Version 0.1-1 (9/1/2007) - Initial beta release. seriation/MD50000644000176200001440000002050314610044272012557 0ustar liggesuserscdde8c27d5899eaa74ae924be5f95421 *DESCRIPTION aba60632f470eb6961688c20862a7d08 *NAMESPACE 32447184718ecefb0dc7ade2b798f6ef *NEWS.md e8488223eb244ac6fc647b85602bb676 *R/AAA_check_installed.R dcee574861e4b9f36f55f3cb7da815d2 *R/AAA_color_palette.R 356dd4c05eeda14cb5d82c0363775f11 *R/AAA_defaults.R 2a5188bd32cc14b9af961474326c2c7f *R/AAA_map.R c954259024b57877e97b16078861810c *R/AAA_parameters.R dd585ee972c5a1d532a7e798906da271 *R/AAA_registry_criterion.R 29acbee8e1b9194606bf1d3cafdfcf6b *R/AAA_registry_seriate.R 03d450d5b57778826f274d54586a1485 *R/AAA_seriation-package.R e2b12f10fa4743e4caa85efcaa2c7519 *R/Chameleon.R 868b1ae1b62abdacb22bca6c8be670b1 *R/Irish.R 539000b38f7f0db4ba117a0d5fbdeba4 *R/Munsingen.R 6d136ef3095c693010c121b69a88cff3 *R/Psych24.R 5ab47b238b5a37060f0afd1f9609345e *R/SupremeCourt.R 7ce555a416c2da52f538c42870f34ff9 *R/Townships.R 3fb8aa35ca9d6cf5a86853bae3504401 *R/VAT.R aac9601d86df7af0ca23916a59ec4177 *R/Wood.R 9d63469253a2a569d4b52d1706bca044 *R/Zoo.R 0afc94b6800d8fd922c6a547539f1032 *R/bea.R 092ffeaa4d61636fc395dec8df278c9b *R/bertinplot.R 901a5e494f966eebba114c52e97e74bc *R/criterion.R 9c781b1d0ac4f1368ab809473233db77 *R/criterion.array.R abc511e93129a605c9c69a57c21c6eec *R/criterion.dist.R 6520b30729a895a2aeefc28f7a3fd482 *R/criterion.matrix.R 84eb8ce41c9bd056f138f302c19a9e32 *R/dissplot.R 216dc0b033f56cfe27241d483ccfd796 *R/get_order.R 57328ee8e4b7731f047da01fc0087f2d *R/ggVAT.R 60c2fd96da7fadbceb5a4187e002e4c9 *R/ggbertinplot.R a16c65981b5ceb559051ce3f67326468 *R/ggdissplot.R 14eb268528fbb163978622c94270c411 *R/gghmap.R 2b899c5e25d1f47007c5f0a441d2c8c8 *R/ggpimage.R c7b45baade6c4a3577561341539f9eab *R/grid_helpers.R 7a4c84190ccee3a653a16e60b0a171e8 *R/hmap.R 8dbf63ad1c1e7648eb1399e0165348c0 *R/lines_and_ordered_data.R 67d332dcfddddb6dea2fa0460666e561 *R/lle.R a7f48b5716365f943cd4143bc3f12ef3 *R/permute.R 05bc387d63c91d5609ae09801e958226 *R/pimage.R 816cd8ffe7f80a59e9629c901f2c9ca6 *R/register_DendSer.R 9deb7480fa40d6952424a1271455902d *R/register_GA.R dcec18a2f87d9458fe474c4acdc9f30c *R/register_optics.R d645937c41697cc66bc909a625ea7329 *R/register_smacof.R 6c34f6e42d79dfbf46d4a32bf5614f7e *R/register_tsne.R 8373c3a81edc8471b15dbb395f60d1fc *R/register_umap.R 504c17da715ed1d7368c03a37c498201 *R/reorder.hclust.R 047d6273ce713dbcab8d48e5ae3f2c0d *R/robinson.R 5adff716ad54a54844b51c4648b85de0 *R/ser_dist.R e6c5f1d8cc543ddd85f9bb67d798cf2d *R/ser_permutation.R b3e595c5ed199b898f8ca9f114cdaf9d *R/ser_permutation_vector.R 052d53c50f89f4a1ecce13af698d0e72 *R/ser_permutation_vector2matrix.R d769279ddd9b553a7fca76805f8e2c88 *R/seriate.R 15c51a1bf4e32a26b569677ab2c723a4 *R/seriate.array.R 61a9f21eab45b27574b8f757e0acf4ce *R/seriate.data.frame.R a89de4367942201bc4480e80a3031cc8 *R/seriate.dist.R b32506e27e61d6b8994da91f8f79e6e6 *R/seriate.matrix.R 4d1b21ca87facc2a1c3fcf19aa151a19 *R/seriate.table.R 59d147a2706939047e6adf8d95f1fa64 *R/seriate_AOE.R d3d5715ce4089e801296ea5c5776193f *R/seriate_ARSA_Branch-Bound.R 06bdc75810c2936265d3a3d9b5610e8a *R/seriate_BEA.R c9649750e68c3fa0815038d98d896329 *R/seriate_CA.R 755aba67e245b8a01b9e642f0c53447c *R/seriate_GSA.R 0756c0b125ab088dadeb7b3ada12f635 *R/seriate_HC.R c21abd5c18c9f1d76adbecd92ac9ffe8 *R/seriate_LLE.R 01d8ddbbab0fac60fa1871bc47e9d934 *R/seriate_MDS.R 2af06a2a15960991d2200235b6fd3636 *R/seriate_Mean.R 2676de50e693ed44068b20d0c922c926 *R/seriate_PCA.R 385b6a142ec4cb9ad5f2990bf693689a *R/seriate_QAP.R bf981f04c36f35c5df7de5286ea41fbf *R/seriate_R2E.R 220836cd994c20cfda87b3d12a9cdce0 *R/seriate_SGD.R d2ccd4308b6567a22f6c0c3c852960f2 *R/seriate_SPIN.R c899f262f9aa831495ac212e7fc7b04f *R/seriate_TSP.R 8ea17dfc9720865576f0b54daaef2363 *R/seriate_VAT.R 1c28cd13d6a5b4aabdc69624601a8405 *R/seriate_best.R f05bb91e9c8708422951543973654efe *R/seriate_enumerate.R cb1b320fe165d064d01ddcf097682c9b *R/seriate_heatmap.R a1c781ca89906c41849f32bdfeca3b32 *R/seriate_identity.R 8878efdedfbf36a39df595393bf36932 *R/seriate_random.R cafbe8cc1602cd87b9bfb479d71ec183 *R/seriate_reverse.R f0d68c865e4ffaaa31e01a350c1e03d9 *R/seriate_spectral.R 4f95b5c084deaba14d6f090a47d52ea8 *R/seriate_vegan.R cc2568a6b382114feeb96ff9ce9558b5 *R/uniscale.R 5f41c63e4ec8a5a9444c83a58643346a *README.md 20c8d3f97d93e2e318a22508275b5a02 *build/partial.rdb 0207efbbefb28b8959b55681f76d29e5 *build/vignette.rds 4f812e82bf45b34f8864e5cbbdd899e3 *data/Chameleon.rda 906d0bca2aedd0b37beaadb7a72e0e27 *data/Irish.rda af710936ee1f7dfa741e92b3a4db299f *data/Munsingen.rda 95b83c0665fba53e965c9f72bc02f696 *data/Psych24.rda e4ee428e26e80ce891fc72b1e3c41a54 *data/SupremeCourt.rda 2148e15ce50dd04ff7e8e144f3ebd20a *data/Townships.rda 443babf28bdc6f8d44c9afaa77829d04 *data/Wood.rda 691665da705f9af86930fdb1e4bd54e7 *data/Zoo.rda ad01d7162356369ccc5df016b3193527 *inst/CITATION b83c5e09150106563331fc90f3e357e9 *inst/README_files/configuration-1.png 17b0552f679a8e871e15fdfed036a38f *inst/README_files/seriation-1.png ee3d67c2bb3264414a8799483157eccf *inst/README_files/seriation-2.png f1e76996d5bf0d0442cf16387ed5a260 *inst/doc/seriation.R 11f977c31fa790c334dade242f12d37c *inst/doc/seriation.Rnw e2b8d9dd2666a13c8dc03d9a1b086126 *inst/doc/seriation.pdf 56a4967cd38248d5b3dbcdcda17179dc *man/Chameleon.Rd f4f94a9ec04a357dc920be1397edca38 *man/Irish.Rd 3156e2ddf2eea5a3d7ea496a4368b463 *man/LS.Rd 5fe634b238b35a67a31bf51e0b04a5dc *man/Munsingen.Rd 58038905af1d1e376153f1a881e3f41d *man/Psych24.Rd 7a90237a1731c3561040cc3b8b592847 *man/SupremeCourt.Rd f21dda3a130d08fd63f3b586737951ee *man/Townships.Rd 60544a0b859951900d4c46dc8e508f6c *man/VAT.Rd 73c7cfc925431aaa92bf3c64de797655 *man/Wood.Rd 5e2217df1d2d60ed8edcf5ef0771f3c5 *man/Zoo.Rd 28979067d6425076abdcc296e841ce4f *man/bertinplot.Rd f9a3a8e358e6a2171f27159d08ad6eb4 *man/create_lines_data.Rd 399be4651784c6c58904e806b7e72904 *man/criterion.Rd 111da54e6f58c336545e58083f076935 *man/dissplot.Rd c8949f771feb3a28e677ed9c369b2eb5 *man/figures/logo.svg 0fd8ee64e3568dbff3fa9e9880ae4750 *man/get_order.Rd 0f4cd70e3c4d94171fdc7190005bf19b *man/hmap.Rd 10d5ad032d6dbca8e6c564d6e0eaf5ed *man/is.robinson.Rd 66429c502068b3078d87ba7dcee0b4a9 *man/lle.Rd 42a48f86b1ac9fd58546b569ed777145 *man/palette.Rd 6f71dd5ce181c294565efa78717d2a3d *man/permutation_vector2matrix.Rd ac56dbb9aa0ebd7098047bcce39e6494 *man/permute.Rd 6d2399fd78465637dcb807b4e692a38b *man/pimage.Rd d742239694eda5069db7cd5f621da455 *man/register_DendSer.Rd 3c8650a2f5665c938fc307707ee1dea5 *man/register_GA.Rd 6ed7f2b5f8da99f0d75f674d27a4669d *man/register_optics.Rd 04c6fcf4ca91afdf28f1e608032555aa *man/register_smacof.Rd a11fc5bbfcf67d8145c528365b38908b *man/register_tsne.Rd 931bd8ac1403a87d69fa82eaf71533cf *man/register_umap.Rd 8fff6d16ecfd83be1b9a77f135382c30 *man/registry_for_criterion_methods.Rd b32f502bedc6269183720b320556bc55 *man/registry_for_seriaiton_methods.Rd b0088fd373a2ee966f3cdb065ac6d494 *man/reorder.hclust.Rd 91f02ab1c2f7c9da4fbe6b2ed9f73865 *man/ser_dist.Rd 37ed59f7817214f47cc8d35d285dcba9 *man/ser_permutation.Rd 2a5bf2fed1029cab3ed7d298f1b79520 *man/ser_permutation_vector.Rd 4d7c096d36ed1c9f32c44e5d239f36ad *man/seriate.Rd 15014ec82877288b96fb03f6deadb180 *man/seriate_best.Rd 99c7057592d594546c9678f0caabaf13 *man/seriation-package.Rd 5e0ca8ac0c1d6a0c6a13f14c96e653a3 *man/uniscale.Rd dd4b979a72ea89fe013a9361bbab8526 *src/RNG_wrapper.c 26855e39732a907da8f87a8ea6fa101d *src/arsa.f 821afcc7f36b26b120cde12188f4e42e *src/bburcg.f ce5578e725f57ca6638efa034ce7f7b4 *src/bbwrcg.f 77b85198313e762449fbf55b8759c199 *src/bea.f bb3b548134274012860e6bc98cdd45fe *src/criterion.c 59eb3efe0648038f9e743410df42e4eb *src/dist.c f73fe1a41d63dfe04f5ea5c17c563401 *src/init.c e3ea51df25cc0fcf4e2086822274bbb5 *src/lt.h 3be5cbf0956a78e67d099820e1ef55fc *src/nextperm.c f7c31d257e9ee204a1f7413a0a9d3f9c *src/optimal.c 67ebdd5746595c9de514e50f59cb88bb *src/pathdist.c 2ffd28e7038281a4d6398b780a71c07f *src/stress.c 4810997a63ce3eee7a2d3dddd06a05ca *tests/testthat.R 6da8e6a3e48d06a9f37097b2ae38cd68 *tests/testthat/test-criterion.R f8db49b2ece831c6ce453b62e23b91ef *tests/testthat/test-dissimilarity.R 864f3f7170c4b5a0c45de4aad8a90234 *tests/testthat/test-map.R c9d38611954c03ce316aafd6d38c8f59 *tests/testthat/test-permuation_vector.R ac55674a5c4c9ab6698fe81dbe5a31fb *tests/testthat/test-seriate.R 88552ddaf279d53c4e78695f61a81528 *tests/testthat/test-zzz_seriate_extra.R b59872d48cf446767be0c79dae8900f8 *vignettes/classes.odg 7f67ca8c5483222bc0a154258388db86 *vignettes/classes.pdf 11f977c31fa790c334dade242f12d37c *vignettes/seriation.Rnw 17446bf1c953326c0ee62c31ceae93cf *vignettes/seriation.bib seriation/inst/0000755000176200001440000000000014610040326013220 5ustar liggesusersseriation/inst/doc/0000755000176200001440000000000014610040326013765 5ustar liggesusersseriation/inst/doc/seriation.R0000644000176200001440000002704414610040326016114 0ustar liggesusers### R code from vignette source 'seriation.Rnw' ################################################### ### code chunk number 1: seriation.Rnw:120-123 ################################################### options(scipen=3, digits=4) ### for sampling set.seed(1234) ################################################### ### code chunk number 2: seriation.Rnw:1025-1026 ################################################### set.seed(1234) ################################################### ### code chunk number 3: seriation.Rnw:1029-1035 ################################################### library("seriation") data("iris") x <- as.matrix(iris[-5]) x <- x[sample(seq_len(nrow(x))),] d <- dist(x) ################################################### ### code chunk number 4: seriation.Rnw:1041-1043 ################################################### o <- seriate(d) o ################################################### ### code chunk number 5: seriation.Rnw:1054-1055 ################################################### head(get_order(o), 15) ################################################### ### code chunk number 6: pimage1 ################################################### pimage(d, main = "Random") ################################################### ### code chunk number 7: pimage1-2 ################################################### pimage(d, o, main = "Reordered") ################################################### ### code chunk number 8: seriation.Rnw:1080-1081 ################################################### cbind(random = criterion(d), reordered = criterion(d, o)) ################################################### ### code chunk number 9: pimage2 ################################################### pimage(scale(x), main = "Random", prop = FALSE) ################################################### ### code chunk number 10: pimage2-2 ################################################### o_2mode <- c(o, NA) pimage(scale(x), o_2mode, main = "Reordered", prop = FALSE) ################################################### ### code chunk number 11: seriation.Rnw:1130-1132 ################################################### methods <- c("TSP","R2E", "ARSA", "HC", "GW", "OLO") o <- sapply(methods, FUN = function(m) seriate(d, m)) ################################################### ### code chunk number 12: seriation.Rnw:1135-1137 ################################################### timing <- sapply(methods, FUN = function(m) system.time(seriate(d, m)), simplify = FALSE) ################################################### ### code chunk number 13: pimage3-pre (eval = FALSE) ################################################### ## o <- ser_align(o) ## for(s in o) pimage(d, s, main = get_method(s), key = FALSE) ################################################### ### code chunk number 14: pimage3 ################################################### o <- ser_align(o) for(i in 1:length(o)) { pdf(file=paste("seriation-pimage_comp_", i , ".pdf", sep="")) pimage(d, o[[i]], main = get_method(o[[i]]), key = FALSE) dev.off() } ################################################### ### code chunk number 15: seriation.Rnw:1266-1268 ################################################### crit <- sapply(o, FUN = function(x) criterion(d, x)) t(crit) ################################################### ### code chunk number 16: crit1 ################################################### def.par <- par(no.readonly = TRUE) m <- c("Path_length", "AR_events", "Moore_stress") layout(matrix(seq_along(m), ncol=1)) #tmp <- apply(crit[m,], 1, dotchart, sub = m) tmp <- lapply(m, FUN = function(i) dotchart(crit[i,], sub = i)) par(def.par) ################################################### ### code chunk number 17: seriation.Rnw:1309-1311 ################################################### list_seriation_methods("dist") list_seriation_methods("matrix") ################################################### ### code chunk number 18: seriation.Rnw:1315-1316 ################################################### get_seriation_method("dist", name = "ARSA") ################################################### ### code chunk number 19: seriation.Rnw:1333-1339 ################################################### seriation_method_reverse <- function(x, control = NULL, margin = seq_along(dim(x))) { lapply(seq_along(dim(x)), function(i) if (i %in% margin) rev(seq(dim(x)[i])) else NA) } ################################################### ### code chunk number 20: seriation.Rnw:1347-1352 ################################################### set_seriation_method("matrix", "New_Reverse", seriation_method_reverse, "Reverse identity order") set_seriation_method("array", "New_Reverse", seriation_method_reverse, "Reverse identity order") ################################################### ### code chunk number 21: seriation.Rnw:1357-1364 ################################################### list_seriation_methods("matrix") o <- seriate(matrix(1, ncol = 3, nrow = 4), "New_Reverse") o get_order(o, 1) get_order(o, 2) ################################################### ### code chunk number 22: seriation.Rnw:1398-1399 ################################################### x <- scale(x, center = FALSE) ################################################### ### code chunk number 23: seriation.Rnw:1406-1407 (eval = FALSE) ################################################### ## hmap(x, margin = c(7, 4), cexCol = 1, row_labels = FALSE) ################################################### ### code chunk number 24: seriation.Rnw:1417-1418 (eval = FALSE) ################################################### ## hmap(x, method = "MDS") ################################################### ### code chunk number 25: seriation.Rnw:1428-1433 ################################################### #bitmap(file = "seriation-heatmap1.png", type = "pnggray", # height = 6, width = 6, res = 300, pointsize=14) pdf(file = "seriation-heatmap1.pdf") hmap(x, margin = c(7, 4), row_labels = FALSE, cexCol = 1) tmp <- dev.off() ################################################### ### code chunk number 26: seriation.Rnw:1435-1438 ################################################### pdf(file = "seriation-heatmap2.pdf") hmap(x, method="MDS") tmp <- dev.off() ################################################### ### code chunk number 27: seriation.Rnw:1504-1506 ################################################### data("Irish") orig_matrix <- apply(Irish[,-6], 2, rank) ################################################### ### code chunk number 28: seriation.Rnw:1516-1521 ################################################### o <- c( seriate(dist(orig_matrix, "minkowski", p = 1), method = "TSP"), seriate(dist(t(orig_matrix), "minkowski", p = 1), method = "TSP") ) o ################################################### ### code chunk number 29: seriation.Rnw:1525-1530 ################################################### get_seriation_method("matrix", name = "heatmap") o <- seriate(orig_matrix, method = "heatmap", dist_fun = function(d) dist(d, "minkowski", p = 1), seriation_method = "TSP") o ################################################### ### code chunk number 30: seriation.Rnw:1535-1537 (eval = FALSE) ################################################### ## bertinplot(orig_matrix) ## bertinplot(orig_matrix, o) ################################################### ### code chunk number 31: bertin1 ################################################### bertinplot(orig_matrix) ################################################### ### code chunk number 32: bertin2 ################################################### bertinplot(orig_matrix, o) ################################################### ### code chunk number 33: binary1 ################################################### data("Townships") bertinplot(Townships, panel = panel.tiles) ################################################### ### code chunk number 34: seriation.Rnw:1614-1616 ################################################### ## to get consistent results set.seed(10) ################################################### ### code chunk number 35: binary2 ################################################### o <- seriate_rep(Townships, method = "BEA", criterion = "ME", rep = 10) bertinplot(Townships, o, panel = panel.tiles) ################################################### ### code chunk number 36: seriation.Rnw:1655-1659 ################################################### rbind( original = criterion(Townships), reordered = criterion(Townships, o) ) ################################################### ### code chunk number 37: seriation.Rnw:1726-1730 ################################################### data("iris") iris <- iris[sample(seq_len(nrow(iris))), ] x_iris <- iris[, -5] d_iris <- dist(x_iris, method = "euclidean") ################################################### ### code chunk number 38: dissplot1 (eval = FALSE) ################################################### ## ## plot original matrix ## dissplot(d_iris, method = NA) ################################################### ### code chunk number 39: dissplot2 (eval = FALSE) ################################################### ## ## plot reordered matrix ## dissplot(d_iris, main = "Dissimilarity plot with seriation") ################################################### ### code chunk number 40: seriation.Rnw:1752-1758 ################################################### pdf(file = "seriation-dissplot1.pdf") ## plot original matrix dissplot(d_iris, method = NA) tmp <- dev.off() pdf(file = "seriation-dissplot2.pdf") ## plot reordered matrix dissplot(d_iris, main = "Dissimilarity plot with seriation") tmp <- dev.off() ################################################### ### code chunk number 41: seriation.Rnw:1785-1786 ################################################### set.seed(1234) ################################################### ### code chunk number 42: seriation.Rnw:1788-1790 ################################################### l <- kmeans(x_iris, 10)$cluster #$ ################################################### ### code chunk number 43: dissplot3 (eval = FALSE) ################################################### ## res <- dissplot(d_iris, labels = l, ## main = "Dissimilarity plot - standard") ################################################### ### code chunk number 44: seriation.Rnw:1803-1816 ################################################### pdf(file = "seriation-dissplot3.pdf") ## visualize the clustering res <- dissplot(d_iris, labels = l, main = "Dissimilarity plot - standard") tmp <- dev.off() pdf(file = "seriation-dissplot4.pdf") ## threshold plot(res, main = "Dissimilarity plot - threshold", threshold = 3) tmp <- dev.off() ################################################### ### code chunk number 45: seriation.Rnw:1831-1832 ################################################### res ################################################### ### code chunk number 46: seriation.Rnw:1851-1853 (eval = FALSE) ################################################### ## plot(res, options = list(main = "Seriation - threshold", ## threshold = 3)) ################################################### ### code chunk number 47: seriation.Rnw:1867-1870 ################################################### #names(res) table(iris[res$order, 5], res$label)[,res$cluster_order] #$ ################################################### ### code chunk number 48: ruspini ################################################### data("ruspini", package = "cluster") d <- dist(ruspini) l <- kmeans(ruspini, 3)$cluster dissplot(d, labels = l) seriation/inst/doc/seriation.pdf0000644000176200001440000122413014610040327016461 0ustar liggesusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 4831 /Filter /FlateDecode /N 84 /First 710 >> stream x\[6~_Ijʺc;ۗNA%GlgwPDn+n4> ,x ] SiBa (\! /x^Q )/() .*f92A+h&Xэ#ABBrUsrSxЩ- o ((4PtET<8U<(rl0X.54WAFg0 VpQxǫ(;j⛻IP9DJyqos=ǣSݜ瘗Ţ:Gɲ4/[/rߧg՝:"ͻTqm"vsq碭;u'yw|=O4UOj\a~x|lE)BiLQ?qS|u3t2.Acw)s7eq՛qQ~֥NO1 oo}SirڮJݦޗfW-{T~ܡ]9 1 <%3" R6T)&?7Լ̜AԃO}|]=qrʦzʧ~Uh>(+,%_[NW˧fyC&syTQgM5Cc:>:G<2$b("^hIc`#`紬^dW bOH Zy;mh^,"gGKek߼[-5 oBvZ{N ; [aGE~[LJfHI^@d#%Zɰu&L9"XY\} kLI}͑`Ch}s9 ՞# Uf.s-:{;b4tR{|RH}z| ^F2*$"3/Z۟IsNmI )90<*1J/]sɣC=vOȋs0 Cv`zlڨzك R $;tRxCς)ZuM1TyJE|n=b{ʞ`#x>؄U,6N)Yb ?vjjMx49T 7lɖG?t>iz.u]CI ~b5DP~^uzMu(͵H7ʱӗ/+ǷWFwnjJWWǔZw^ `:9,6KR5()O"0ǖ0;МQ692U}U$݅" h%;`R,CqkI :T52N.*r\T4[R2X,bgo~2jSi^2WE?9620-]ONFsHί'\Tv$cE֩l{w6g#Q,3-Hѧ1Pv] Y_JMqbv>m9eg˸Kp^5~}W^PO!uijCҭ&/`¶C o>xؠ4$wRr8Zreͷ6vildCNacn:˚eYFSV}OG[#H8 2{i#>""GƯvwD;XkA4_LEvG@wbFL U:hiɒ46TrBq_!P^ +=.|aY׳-7;ѓ֫K S$mJo9ձg ؄&6! x:Z^'Ķ޶=uhN0b 4\ý9ؙc9ܞA# "OQūGkWhY/qSkWٜˎY>!nݮ :$P\Ǖ|mrz5E2TEU:E&G\`bhj[[+0OWPQ@^k80n=|p'نJ;'*XSCdD)^Qh28v$DŽ%9(et͖ 2l:6&K𒢈* GEdz%v aK`;WCA'e2$s )JzCV&RCOYeK_Ji-&nbf&'p>Ht8RQ d&H,qn("$OV(gƷF1UrgMe.V-&#a dq>шbR:߾|ts>'*KTo@r]❻]n_A?W*r\M=Tl\It\^v^.EalO: r05 XPK79R|g~5_4|!7^zWP!}µۄkl%!DsS;cQ}Aٱ{^rB4de?XQ4P{:1Ys HjY P87Q߇>BRS~}%)یBbd헐'>l!ojm)'A$^:Y$R l *dӄ[]̅yd@%:xaZ{ɳ֍z!~z7[U=.i{DQjYAG݆*|"{ck;<")6z>via=-7=-!( HH^UW 7){ypMcR7Ѿcɭ˓sജ/ΠߏΪM*m H]Dע])N(JEN)cJ͇xSe3jWBLHS뭬W:K}Z4|1ӪQsŞ+@(@UưÑ 1Qs^HٿtvمV_HpA ^6hV[ϛMi#Iґ XpKBG٭SV0fT4, @נ( z F6h]C50&XwjQ/#DWM0!1[VW`M<;N:NN7H.#uA<]E: |6{ǔ';}obCZl8)d?Qэ=m>؎n8HR9߻({_QCendstream endobj 86 0 obj << /Subtype /XML /Type /Metadata /Length 1554 >> stream GPL Ghostscript 9.55.0 combinatorial data analysis, seriation, permutation, R 2024-04-17T16:36:22-05:00 2024-04-17T16:36:22-05:00 LaTeX with hyperref Getting Things in Order: An Introduction to the R Package seriationMichael Hahsler, Kurt Hornik, Christian Buchta endstream endobj 87 0 obj << /Type /ObjStm /Length 3146 /Filter /FlateDecode /N 84 /First 755 >> stream x[r}WcR.V\%JfHȱdC1P%_s{z ! tcs bdĴ,IfCbI14d~£d2&䘲ѱ)0>G>L+i%*i+LjCie:ڄc:P3,Fi2'fM$311(ͬ@ ȕ f-(S3 RdF'2 uOIФdNPs&9aG4֖883 Ёy0[M.^ʀ,H@WYP^Y (PƱ`=F%5,G# J$fZO F@;دa[kb Za[!n)4풁FUNBDБ|.HX'M["E5u +O]&!8 X pDZS-%\O3I<'dFb.a4r Ҥ G&鄽'Cڛ ݺTԥ4tGēpZ 1u[qV]'/FwqI;FVZw~ܫ&bl x{SM18z/՗)F'TU4u˔d q q qB)c)xZ!hD.B.B.B.鴆(/|QHL!L!L!L-`xgxEuU* Qe<&4C&;#IuhKCs Wr9<f/?@F$39b]3<ԁk<_-P++7i65$8lj'Pwu(b {QHĴY#JJ=DK=V\Hmt(pG|@茍R}󁲵?J]Q8gVNZYf5Js(܃} 7LؐKY`eV~P1/ۀGuPm3pܜn9!I$C[H+0)d Y{!9xBC9 $mR 870;7W s$a)7a'-G/Pi CPZ;CGM""a6q$@P , :7R\ ;cnk˝j%GN~5bGZv0_[b{:T"IXD $4 \#I+`=9Юj(@!4y9<[ }) Ge$efuh8^U46pR ߠuGۦp?%=+deДc AۀIce@ &i9$/ o}BP4Fǣ(ȴ#tQ i`X 'd6~~.^2x5N, ʴyi-L&xr@voTfʶ@aݐsUBi<0r[ />sCAa1HAg]A5>o"r shW1? sLp ޅ)6&.F9Ļ򉀧#l[6`tT`*ӚŊmoQt#@+zhc},²!ÀjQөmPE<"/TSq-L|Qꖂ0 !Q0)sPNwT⺕Pt@ A+x念qLQF$"_NoH]2߮>Y_[럯2ڦշ{?lf#!$tU|D.#H(.ʼnx"ũx&LŹ7/VtŅw{ՠֵ1Tc=vť M@\J\AŵWi57M5}A5[1ۋj<_Hwdy\D,ѥOG~4./b,&bR}1ӛqU瑸CāIo4'Y|_o9d>DXדf ϯ=9קAE+=ӣW,;:dsƑ=x3nW!gĻ"fs'dI2ӵtI]CK*9Giw -a)|o'L(_w}}Z~ój{G'Vѧme-oJ'|cǫ:ע}iټI֮Z-T=k$}"6q=k=֪ V-セ%ʗ N\%| ?"uW;;LrhIAV z&mgߢڒ4Kcӗ69Tjm%睡zgCqkH:ϴ9mz<;j Z2^V,ty9LcǘuZA8&5cV :Sh*vt8,.hahUxt5uݟvW}09}C:"Rxn 6/@:E TG[yDtӢnl,l'.k 8HIbmD\Mͬ/6Pdendstream endobj 172 0 obj << /Type /ObjStm /Length 3371 /Filter /FlateDecode /N 84 /First 781 >> stream x[[S~?bϩh $$dsaMʃklb=HeIR.H7===-5LzÔZf1<CI# 3OZ9*AiSLNFg eZ 6x}D!0#, G Ɍר3%ZZ02zʡFb蘵#zfDG#sBDIQiPPkQ9S0-M2E@1/R+ϼJ:[j% $4/%Ѡ,UkPXt:@$% H"¡ffdрJ)-u4U02,I)BjJDJ@%55)aiAu$!JJ=0Z @ɓxz|Pc(bYmL*'P JC T$hZd JmR O%M@%Lf c>S~g|Ɖ2|o<<ÆdܩDIaI]sro45U2K|!3!]DwX:?kʹ.mûG0p2Xj^ ѣJ$gg!*f8BhMיD7'ta}^d_k*n: 3=9Y19ٜ?|$f/٭ѫC f8~y2w ̥XM-V1žvK'.j@&Or, Ny]ە gd6_-)Ʀ)ƱCmSC(gvz{??Q+&U(6V/J>d'9". y*B~5/7l8[IRpo.+}q)[[%)˪om(7*']eVzVM!L#~fnf! _utۈr⚂r;J Ϟr/^X9[kz!@ Dhc+3Ww}+/+BжcW|Sn`IoMc? :}}nZj-ʆ &cHS.3r]d)XY>+%òYݠ(<bAfP{Jg O'APA~*ʐiOcbFje3h2-z4b(" DF?,xV"Hg ]H=$>x1sfœHVTJVg^y{R-Pb Eh A@GD[8I*/ݺ5r=@P*И(I&@5Ey'cTaȤ| `vLoL2‹@)lh"Դ6 qQTy R=05%)(}5 W Zi1z/\Bb6Jy|mp1\)zR<ѻ?hު Xݐ}*O_nˮm&B[-FiʔkmH=tlLvJ}g n4؁?kLOφyJ8^ͱ֎aoO?_S_ݮ6/Э}Ao vn {J|UC@`/MUАBgk'ĘXOP<N-!RPln"m'jWobo{|jd> stream x[n}W.%X,Kxc;-14)4}!) {OWWWjg&(a]U FĤq"ZŌ/)o6FD }EvNA/Q &Za<12jA_ zJ$,M;:H30F>6e|y8 3op=(\yg+e ڹ>L%c^YVx3z6qN@WQ9$|ރč&bd7V-f"o!y2z*N* ȉdV+v"zXV[`?=)"YϣH$R._e52JdxEvDhȁ)G+3eLꠕaڡPX( TC+븖А5P&k-{F[} Ƣ6 FC,;h㠥a ӏ?|Xe_z'sp|WMO^^b>i oK| \z4Y-,O'+^3巷d_=n{9aW<^E\rժ.M5 h݀5 Xik80)=Ԥ: #*] -(ev^@u-|  $)FROiPK tʏ*$$)}`ju4 \:+崖>d[>ux0})#X3-,F[XVǃD'Ӎv9[f$a#iPK0U #5m7OPhL6[?10LCUIyLibH;iZL\$jLI2)s`6 3}6C[,]4YP"[}}}KqYacw#I7s:W1KpS`b΃KZtj !ƴ"81a== 3BD.Ў3E=BK7oH˭+=!'ٞ`AE IJgI,`uֆJ*kYY*EEOZ:If`u"ȅM3K8be5܍O0aiZ5bey[9b55knO[Zx|c% Ĥr'222b$_*@aΠ[P !0uG܉jP- $Nr,VbwaC0:.vxWt lYR1~Av`:t4x5)[/'?x~MοKQu~8Ea:2_M/^L BZr^R/4L,kg jouٍ5^rWSg˿M#z6Z'ߗU)mzW"xJOANt6a!&|Zg'لcVG_T'3tף?#!n+UgH?*߿zv|SO{F~oX` r׶k,%ml޶b!uIrռ[kOTW']yUէ:&տꢚVTs5eu9YNgղZUKmG~0*sUʏ ƕ-Q-o0GL lz Ĥ8+6(=?\ cYꪑS?? &lE)sY3}uI"l@!R0̎画T(,+T)9Z}1b^ ()~gPRs*ò>st;r]C '%P9?F6 Nż~z}&t9gr#|15{Gpd_<ޑW׎xVzcl1/^\ƫ xͯW|Ii:>?z̴3-{_vo=&&_NLn*b7a )wMOTu8\`t:M]`9 71@2- `eA/arnSfI͒^ v8[xx)XA+<ɠwd% Y0<ȪxyPސX~8Ģ7d/JݖC9fܩpJ*`"zC'mMn&oF|3Hendstream endobj 342 0 obj << /Type /ObjStm /Length 3051 /Filter /FlateDecode /N 80 /First 734 >> stream x[[o~c"/7 ;q Nuݤ K#g[e7ց.9ùjUуwgl %,䄳^H*F &Nd0B{\uV#aO8aK^A,xR)I|= Oy+HYI;ANσe(_)Ǘpb栄#Ǔi2` P Vx Y7“KAxǠB>hŠ <*,j4ĵ@F+<E'BИB AD(1$U')՛RJXl"Ia-()X⾤?,ESCe%I #LfBZ#X#E>1rjQ'C<(L i50hm`554+U5Hc ``XC'h40#vCo1bT=߾'I}O"W]Kۼoً }sG|ma=<}w~ar_nD؏]wӫJ)y0MS]amj<(yլs rb3gYUS%RA{=!zdCUB\Aʈ4!B9ǒV ~(sYmy3ID$2SI$潯.i˵- vlӏ:ZrFGq%ܱxL {OkXdgkS2kBdQRl{{U5j6:wbuI7b]TuUqGxt,SGedht^2S=\MNN8&OZǚvIY3,\LcЪ!ƪ>j~H%<5Amn5O3,j,sY\tֳs̬DFDUK~lz?2L 5kz&N M-vzү1Hz USc"_M:j0VlIaw58L3_-;|Ni߅r/ҬzۯSg ,CP,`dnQU_{3`}%[jsPƾ[ KfZjtTŲ} hzkh DP2F*=M^h]ͶNpw&xKzƷ_چ*r>3Uk9y.5Vf\cЍKo8 {w ր=&ϸۖ+È+KNiBSm(C&QLjKgr~f?N=ˈ|l3/2E͸EW72)z,V1rpq-Jbim-ܽˣ$L>/(>9s%p_qڈpT͸q4^3G,[-oKuUɨ_:hg6ee.hViJA`,M_1-ar.k믟߼|ugKqb{޼g߯7onÉ>pl&squo(zoz.[m&ozr'_nzYxSVdSaw;ɟ QoW^; ?-`Էtz}^ooA]?D hVҷ7MAr?I]u|'q-o}%7Ϳ+fh6SPp_$œ"~UL2%LH&DUtmGgu8dl{I"%4,NG8Z%Q@϶+jB&H [CޚDJkLv{`ᷕ5o9ġ`YPҶЮYO)%*B׃JT ,ԑgC*),H{jt5=Zг=jd~ B7󏛥KJF叵TQSr< ?@2 5| Ls~)0YeO"T!!q i]9DSBQTK{aZiX ]ΩFC=[q2m]Y2ޡ3K#K#K#Kǝ{Yw=O Fbj!` d >jGS˘tмcjJG4cԀVIJ#TCsAb^[Y'D#X4~ɏHe?ޟ~(T6DPS:5{E9%7{6̏)swl iah_ѪnhUWݻhޝ0}ˎ~ڜu㖝oכ52.CbGþ~[ӬLs3tbKOxK"NUwU aź+;!Ǐ'P_~|o){}(H$})vڴLյ "{?bR#ڏ:Q6wؘu  װ~x#0&22稒5Idi4)Ax]FofY^=* 3 i(JcٻDH"OIDŽМ";;N}8NSS q;fך]Cw ۉ?2$xo P;FCD2kڢ>_$5ß/xPӎOC_A>8kR\#v()S*ytLj{L 9[Q -ɏuR_:)O 0zendstream endobj 423 0 obj << /Filter /FlateDecode /Length 4753 >> stream x;vu{~*AqbIld1") 3l Eɽu hJ& 6UYkeᢻx!p?KZ)E\[g쥓_^.~l~Njyx])gڮ{xYfxlnʩ\^ <y pX֮yHk~Sino,|̟M3s0[&; %8855ƈ?wx`ovJ"@K8a3cуfzcyRc$J"?TT3DF ۼyݿ茒nL[T6t%a(yy%@8xU9хHx_ew|#iÅ 2ϓm4ڴB[woyo}ymW `6vk+-k~ӗ:U6%s5ݼH8?N[5x -70 A#'QGCɫKFFK<S2FP`labꄟ!N}mdP$Cdu}IF[省!W|z;8mKl Ѭ ZI Ɖ1?do*X/Sd?/<0QI1G0`|xLo*3(lAe{HZJVP% L併ѕ:i("1L ꬪcVUH=LE=,;2@[a Rc %paTR 풆m %2lD߯MZJX>T?hdF[@?iL^2CABYW-OBPR+Wv#ݔxA4ư}L}0% DZ_i朚Wt_"Ȩʕ*=?A8/\BL 㷈''41`]+2V_ʁF%VQξGW,螗XV"-c-@9YӪ$:9>*42|SWS1*|F]aGi`uaDM1Іt)9_1%P&>1`&g>-admg̷*kw1K i6:vpO*:P8UrHI*zH@ȕON`%~`~) Ѻ@V *ց,BE7KK1/_2?~)3VK/`Ȁ귅]y| ;]V%_e](7RTCWU]GJ,9V:Hji}'S_vsV'PCj4mvV.̩|2b/b_l2B[klD+mb vQSh3ԏ-Ş;9T^nΐs/ tR0h{j'd,\#M(GN1 *\3 OS9]`u|3.@ux'-DbNb)UIS4%#JĒ"0_@[昵E|:S+}+ijM#b6I@{tý* (9"v+li8,&gC1~Uwt˴"XSu!cA<.yvMZ6sNE|,枛^7u8:NJ`ԩh)`a!B)ʼi ^#1#5Dy쥴jr1722ל^Ĩץ-M@*$nteq)Y"޼Q֫A?V<N}Hm+nh p{G8z:L=EW-D,q'g8뼖z./B.Ŧ!Tc)a ܳ6< $1 *3Y:,b`Q?4;TF8PEgA37E1$OJsoj]+!bKr<]]AcK23-|wD0X)3Nb?So"KdJefjoeӏ3$v9.I$9tuVon[*7S%EPlZ oOaJ4byF;4Z4ȷ&B*<\'d^yQ8/s:;+IyhCr!{C__Y> Z dA/SO$q sPݥB+^ %Lx(ULJ5|fށJ8:~~UŹ%ԡuVEEȉY'M5fᔊ}R\Pb!w2ߠVا>pbVŹ`8LL$oP(GTEǪȫU)Ks] Dc,Gl RrN<ӥzFz`hKrA.cL%CO`3K^4`űPRH MUV }%Ǥߨu?}j/b*qx)9_y!Qof4&~@67e. -s ,z ^uhw}>\'9#n23z~&BYѢUT&1kyQD8^$V 5@QAqi# j@ < J1jC7dU6ytҬUDb93/+jU,8-mS!~Ee&WÞ}^Qq$$Qh^ǧ;_ E$le@dY%%*OK=}.tE2(fG#hGC5ڎxyvG*kX D>ݨjӶ[vyP̅ƦlZ=Q vѿha({/qݡ p.6S+ 8Φ/,&s۴^ͫ:*gu&Ծ\3$<4]; 2O{J7NmҿK#K r`[LPyXrŇnPd\Y{BG?j475Օm"6i'O鰰%Թ=!&f/4?uC9!tZf$endstream endobj 424 0 obj << /Filter /FlateDecode /Length 5820 >> stream x\K7rO˳o#jawkiW&ʇkR4P P3C =G"|1b'EWO~ſa".pANn~mW/0/v2i/Kcqy,KT2MüLRi|5ۥꮏ#'*O=v 1Jvvݍo.% l쏛*itQzbvBFyq6tڪ viX iO賐喎/6HV05AasåwWNv4z'9|C.D,/7ٗp)=RvC[m$O1E!7:ti~m}-([_##HuǓe54/9:ײ{5LoOKeBqvQI`1M w X[*HZO+WQYɫ}4i(6V! yۉt/c7]4`ly)DYh>xE~dzE4K IA]EVN@o UH@ФMR1RUGh/ ,rP8pRbśs1I;/N^T-)d~o%43HۺQDJVt_BގOߞ05E9@ 6N"}}{ȥ)ߴl@^IEHM/ŸD6)ƶ"u zWYP /3Tŧ澰WUw>`H)lɤ7poh0!26F ՏM0oXUhfZ(Tvl,Tͱ#)d}JZW0Y(C-3™?1O0<}b9Gh?݁nX9~KN28r[b,LArXNCl _FEƨ*F(S׶qξ ƔI5YeHCČyžۛ2[H,1*`X榀qN̼ܓO *@Jk9wVY*nN*ak@eԾN+,8 q9A)͙\8q rmwxmZ$ൄ݇EeFX&>M=p mw2G @0 m- pw8Yχ#1'AZb ܁\9ËS]cGQ#GDw J9ݶH&Q2XV`vq`|ʢTA ā~R2wWЃFQ7W?&0*=+@{<4 0pi8AF,.<'8K&T:m:VcE! iY7+9|u \Xi&6ʈP$@d xCcSܾXڞ a%Eଁ2}W3RǯU ᐊ^_IK1Zc23 a'X0h?j-*cVju׊jJebL҂8|,|--GB'Ɠ Lj?76s. seܕy .xһ/:vV/J ZM14A` 񆐿&тPw' A-1t[t;rl+L,V1a|xE1ϩ<O^VʐsV+`>xV8W`=SW@Z/.TիÀ^Ӵtr3 `Ps_. S <ݫ}{ہ.ijLf۳yE?T[m(aCf"`DxM+g@1תT`׵*oϥ"`.}89 g6tyԷxnakiĕ7MeEg?S$,8^*gZbjX`9cY&߳jR_6K{$ڣe3L#°BA\ZF.\@w>$M %fM|:=p"ȺAG:fnZ7*I \wUGBqC%29"GUPBJ9eϮ2wtLtn@}f=_C!6ǪvO)H֤F !&J{ b.6T+%#t9e=IEE",c5p@m ޽mJiA !yw|nS EcA[)OE+[T]9_T05K t(:[`!3g뜕ZK%ʃ#Hzw QԚMZ&D}Q. >ָ_,k PX d1(r>=`Wx.#(Xi;VKZ (dg4GV75`$ju*J㻖[whXQ%{mVޯtK𪝖L8Gx%Xwwi }x7a=p{h Qpy;狅ͫrm' _erpӓH$^Yk6Lj/tIiS|CRUnъJVӶ紉PȘr ]V).[E:jU o 4x_$f9BLX4D.M),.! G-aO҉2%v;n6O/ݯY@>7kU*& ᨒh7%c*-r).}4#MuR $EgoSU#v-l" Lvij8XKdq|jY1Jݗ9 Ϩ?Α |}Som IY,4LJ盋:'ud8N2 MgU$B4T 8P{Bty;w3j#9!WT? sؼS0,B`C٩{Vg찕Hgm ӣK1W֘ij94nGHs0̘h6S&k5;k] ^toLWf1D2?]xz6Xz)vOw/gM #WFdZ#X;O Mבk8nڂ[~d0‰Jvų 1_B5()E~SH3z+X]E\)BޛxQ$!6vPMIƻ"M/ 4Tv_nfSL <-Hf D{ZqÙZ9q uǔlw&=Ty#k-邧-<"xƅ#{zeUYI$,]aGަa*M+ꪉJ|Ψ qP Ij q2,oϜ66z y~gXaةVoOMendstream endobj 425 0 obj << /Filter /FlateDecode /Length 4249 >> stream x[Y~Ǟ>"% G ĀjvȒ Sţaϱ@vHu~iF Qެ+⟛W'Qfׯ6lf!N@kMA G\^j/(2mu9~UNZBp\s?5%qVaf?یXww܄[bnP(˰SlɅa ͷMq6%H,hI,j44J_?:F+BvD+D7qז \L>k{6!2BGsLFV?gp bQ{:O뫯tfA@O(:[] C˫ZgZSSj'a _p eyV=nf&"}EhjyK@E,U vqYh,I~W%|Upb؁v姚XDQy6Z#eKL.$ j>,9YZ4}<`DI钷Dq*[Ts^;6"" 5H;8ߑVb`m3#Ui. Х'tX'2LIY3pJ:S@bt85 #). q7#,TXLuq4u'X-Û]N6{߅@lUln7 u1Hm=X ,y YՅl6q&m~M^udf$ '}mzϵ9gQ)@ y ('(9QV68dP֧yᷪpT4w) pVP r{?k}IGu? n}`;dqTBff2 p'67˦_u7^!5`9e&@)FHB/OϼFv! gp4*]b0.Wy@3Q8rePr|< @BaQ[4BfzDo$CAzn*C4,]St\18z}/_2L|sʻO&=j6*8uKHtúlz܋KUE)1e ֿea69ߟV` |H$>2\2-M5D |>ea1ʦ?T&\HH|7 pq/Lk[c]r+[@hM* ?s^Tw :19-(<| k)Ǚ Ra;Sڂ@5d&+Q OesJP քkȄ*XT% BE;9dDH*U- m:TjPI8X Xn#V$c ?2̾JFkxFS ӘMC q84峜Umm8Np}I:]HyV-$AcNz) ܈/%eUpbʸ#\=烓8r1a@S {yEyN g(^,&ۚ%]5SD 櫱vyMYJT-)RF;$if(dȢ9$\6" jfmujA!st&bLRK(O(\+A[1>2}ZTAz[uE/O!oM[/ !~V }8o"} BɆ~B>[l3v0+/kָ0ܣECkrH@̌3/7?,I8'wQ!0`3!pe3aMuׂ~S ^ MXq1{Кqk?M`?xӸ!nK8H4Ma>H]n78V*2!$@!" <., 6I~\ }u|j F$ZK\ UCσnyIXIhE.'K8umxts_"eMnh\/).~!#@9R!i8t}_8mJ&ocy3eqRpb#)nte8m`0@8v{_mvi6U]rTzby7V>Z kȯЭlPBT :bȗ#P@P<8'p CArIF%I# ոJg_M8˼G8 j& 01Ãa2@YD/ݶ"Z8Åa8S2T8Wiǡva' ⓰)gr-i>|.uK޵TAM X8gަY2w.24tI5B#tQҳxދj襁ǃK9Vvtqzl"̣B "{r5C&Q5D"L#M)'EnZå)cݙWuF([zɿFh!JH|mhV]uNE&ج4XV Xr#쒁eC/[/}=*, ;tZCY1_Laʪg.ź5Mŀs6Qe轢1&$n"AdG-Z_(yW˼a*F8wg{9㕁<'f5/ xd8;ƳppXJ8W Go19|VBŧ2GS>TqGx"Rt=~z=d52hցBLuc__uIendstream endobj 426 0 obj << /Filter /FlateDecode /Length 5756 >> stream x\Yܸ ㍨}c9T7b];^a{:b!G-uרKCRGw TMH$_ϛWnoW;xRM+6﮸ojۍ3n\^UٿJnԍQN4mս//aSJMﻴـZm$4ТU/QGjZ%?ɠ/+[W:]}wԴ^~LJta%׍] xb'JZU?]YO_U/OLa*]NX*Xc!s 60VM7*Ĝ5ZVkm9dpÍZUоn,$lp 䡔ıDu{8OJ#UVNCS& 0a*S{Q}Nɛc7/BFrs߾dHQ=2EKqr6"LA H]eGAwȘ=VV@bƘ!5[pBe못@ /L)H֏H ;CЮ"!pH!6GI3x}04mKGx$N-&h3]k {ۆ6\W&[G] 5`kT@em=tqy\!զNK w89 BZiz;TJHQe}'Bt0akaRiE_F(5J@J'OTN$[KN@s6N4WšZKZ &TƂnšB` i93RmC&=z ;` MlJ,ЂaFܲi-R_/ 0a>NI};`#brfӟc6TIٌ `Su3,/X5]$N4ar1]Z7+klC72pdtP  !m.=$͠ ʹS )eۤ'y!d05wQ? 'Ѻq?BYۚ!"%'جh>'jeƚR/vF )۱fKoklgՁ9rȘƃmZa8_V U-ȮC0T|]`9iwM8,LkW=XX@ h!Ec'b._zV5+Voj(*1sH5$Èb";ߍmzs4C΃$QSX` $G.{1qW}ޓ+%h Hv:#QQViHuJx>,:S\m|f)̪D8C׋Hq hĤ $jnÐ)\a)z^$MDa׹zgAG &V,{!HxƸrAc} Jx*_sMEP ! x!zSɪq# TFIӈty8<(cDPh5H2Bg8qr$3fTR$HGj#-hcAޤj^%Tİ,jƵZ1{Fks'&LœJWVI^q |KzPJv%onD4B3 Nm(lE<aRR@L`hh6d`E%Z%V}eee&q}Ad^g&="4_`\)˳UY ObMq@9CQz\s"Džxf K撎a2BQSaRT/rR ^ L5pgSt8|xPܵ"aA+i0-C$i:; 2{H"dIU둱Y GĬ5CW8qiTkHfȻfRV#Cj~2:g0}JoVxH/R?sb0'<捵όdEJ N fX\?mcZk* dæ՚i?mEK6ߟ͏XVj11s ` 9zX m G39%x3^F춏#gS TʐrFl W3ށ&$MEXD`߶ 12yưYo﷤1s|ۧ~37 :V,f?N +T~LѲ<\6DA, #'ItC^]Sޚ}}:[_-5JP0K0QƑq d|ETDbcӍ>ؑP)8`z!OA~RT8y'0 Z &EB8X<vT^<{q=CuG)8aɠBh/ 90PP~זJB͜1$W/ȭO8 k\;ðѹӊĻ3=bȂ%eLJ_5 "n%y8EfTyr=7̗`jI)"N ZL?XPېTvRRD4A蒤OДh49L|%0qc[9{)P0<xh3@J+eBT!rSn[IE YZ evcL!lleCh9oCB4 Gi6T!Tǃa:!][u>PE$>jL!FGN/  (y3W"dLǃ*cHTG8+'j" SizX4mk$갟X1i=d'V).˗xgodQKUUYiV\cVԵP|%3SL EIݟH+S|wAzfλd]~y* NF8E]h\\kr+ !.AbZqGKУ;|cqE V,ռe4TCb}MҖ؛"gp)t sH:C4" H bFYlc? RCz CTsn3+L,*%9r) hp +WV}"^7EBbu$iY`~'U~Il R9< yZ3V`ֲsX4p:gmF6э M1,oO>{{ o1F z+Ҫϕkb~qiz/@4.wNX%Jvf(Qgi, =m%wc6ˋ3GWĢ| J' :ZUʮb1[9g'Mpor짴oKm3$M_U@J-Ϯ'MfR@ ]&t*.BB+?s]nc©g [Q&O=c 9GbKwDL\iLRX⍳yRj`櫠rdf9M.\Sa63h'?M郹WJ.L$!ueC9 Ψۧ2DوHPAݐy:@NB,Ѿ1c#5!Oc6stۥ>_<#V#TS sO\ik(]eR\yĺ!Dӵ v·0V>nO3!mIjcmx_+7([$j,}_LOF8D4vѨtۆ} nus Yz 8(7}̔PQZ@Lѷ&]y%ğſ F."V2) Si-Cendstream endobj 427 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 6011 >> stream xX XWqlE}51Qq{ʾ(( udEdAZ%A\bc\f51c&8)dn&N7}]]U?)cэd]\yOxe!SD{88P$yN[`eqzDk/ƅ}LbSQ~>[^qr8v,?+q <7D9xotX0u;!È`M!K7y8,saEGMaio2k-sBnm~xH/ 7-vY}i@`ЄW&NzS>|q,b3nf13Y cܙf3YΌbV0f%3ˬbf3ƙqb2y+|f"ļʸ0;53c2v3bz3}dtiƂg6ZvN>Hn?PX(()X%)8CA,XZX[V=,sUgGwX ֱ+|P?U?~.$]SUշ?m_^0Y\!kk1aIN[a}RBImf!))ɰ (rJeznM Fcz a"qR*kP5#T9rTdcW.]i>j5Yee|jcvB;wIY3vSߒZB&lԐkZxУs7rHI؛%4\9)LXfP_y6tUwS>&=qH偻p{06$}=85d ~q.XKf wT.~V .f/^1b ZaZJ Q2y`bCl 8h- QwO{ŵBif8B X-3FĚ1 1,bj-#UE;@gZ1Ľ} Ɖn=9 {zVl  f m0syo"PMp$ \b/Pr359 E1l>Ba}bA8_lۚB?>i :cV[z"PLwHKQ݈M|l J8@BQa8> J\#(2 Uk|%(=wdEW* *n[lkeu ůrY|.ۼf>͏0U2 ~5g{JC>>^QyNwnhr^_+ɽ 2XhFըk執-22Aަus4brfh I7X0-(oTc'GmB%(ɓ"j^q`t?gϝir%1{ݢQT(8M,?”S Q)T UN0&_/Wrq$jTpr)b!e9 sI}(AyƜP%` ib!sGw)B ( 6϶I$Sb:ׇ'{ CV aHH(4B>a1Ӱgo:SjhmhgˋmW1ZefhEǡ,CȆЈ8OX#]ol<!<.vOq Z4΅9Բ4 š=Gy6bOZ%Qx`.thJ,l48^.2+PtU 8[YiHwCTxHqƬܪ!؋,nΎ4&p*lYuds14^ӱ-6] qAdaNqά ӻ5MgvIOK X7b`tV\zU ,mP \ZyY^0{U] i{i{nYnd\)4YWQt$lux)B!q>xqt'I=k*JF r(jæ ,yL\ONE|wixoChVdAVy wK5o*n' y3 wRlx\'7;>ͬ>f@QeKܰ?3/K՟}5n"5Ɣ$HVV6Afiڠ\yNkㆍyKf9T\x}0h!DGq x^3ih|O,WpOXt"Kh3!a {5VBstTg>+'}+i=Q eZ/RBt7L֒Q< v@vCJLet?Jڂ3:F=%PbM;h}if|ᄡoioΞLzKgo|!6a2/ FaܮWܪ蚐C.yo?͸ks(QGxj£ޚ)ژaOo jDGFRזylD׭K].o}*4OX]&B(TmflmDY{Nn9 ̝MUayz1%ί1\x~%4J' |3 >>~>wjW]L~t 4T޸BYd9:6ZMZD=x`_ֵUū`GA $z-B𺊯^8C-W?ɦu"g?QOp ?$Ün*[z5i$ p>iR{ruxnn=1MXԟ 6DЙ :Y⿦P WO_afICC忐?a|k 7v =WN{v]δ4]>vhc^NnǒڢoUry)" 0eyi,%qWg ŞɎ R?Ʒ+fȇFb;k6x! #xMґlVA%|UeTi}?[${fnvas hXx_;.)6O8IpAt̗"dr1T;l0R[< -{RѲܨ-ͲF7'@]GJxێ] 3`m㕔=Pf^;pr󎲃%KӅ-%=h9kY^Z "qԎD)l皱GQ@_`ZkH7b7 щ8W~GW~]5"n<}eqd W!6Ko~>aH'@$s T ^ >?j9 Ts U^038se~GYz* [ْ#1Bey[aHÎX/RhQj?PM;?HxQ DO/R ubI521DzaUa) wḫCP`˙r85,>u{!/r!)N௴l_JnV)J0Sh izۗcLk0`0O;0-{K5| S;?jͤ&cwZc͋#1Fx=4OUiJv6dsػ`ps?aKBc(hk Ms8O?*x4kEIJ:8lts#\Xk=žB:7GpεΡĽȂxVv6~p[NvQ^=qgMDFԳr͍QttyNxĽHM!~(]DnH}gƲ/O/[M 5½ǎPn4 فb?F wU!ۉ0r+gU{ .)'0\()vsYsx<9 C՜G=]*[Kx .Cd_9Fƍ^^GMbs=qyǽ"^S]?~F U{  Wu @uzn֞VCͷW|48H]ɐG,-ssk!Z -ǻ2_5(;acHOͰ|K-jsVd|5g?a/l25;]ty;"dr1[wgNLdrDꟓb!@8= COڝG%"=ɣ#5{.MZ%l8[a>psB!GUh:iyg~*8u|WJkO}n =W:P+=W"ݿōu{4eϦ@q 7_miWgERto]Tznٸ~_Nl`գ*-5--՘{ʪ1xncvf1;ݪ'Xߒendstream endobj 428 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 8544 >> stream xzw\T2 j`]cPcW.U^20zCq@@{%&jLb Fob411И{89gG@P|j[_g)'ںy8WGqCP+־Rt$Ao!6=5t֜0FEA;=VV6Y}dkg~IZכ Em۴-? Z4dY+#\VEڱ}:O۝v^}6ntucƎl:t;'J&7 5A>FRw)[jeGSc({j,GmSj3HmSG{j2B-R˩i j:AާVS35,ʚ@Sbj %Q%,j(u)IzRejKyT_ʟG6 LHꥠdIpti 3gKt$ӗq!豣ǁzZ}6y׺f|Cf ̝ ̐\4q^vK+CCV 9?P;C aeeMV>{ǰ5Έ##MF:]Ũ5G3b4o1I;o`T߷# h.pdm &S^}:̤) *Er vNu"Zef7髴9!da@tOLUjևn^([CE6?&83\gL!kZnA ;1ثl,mN_h5i(M*GAgp< MpU Sih8r8Q*Ae qQN< ڛ<4tU Hֆ=]B|CVJ_`akWsAlOF!묤=R`nH,C[fb!EjQ&0ķ6AV$7m)2Tbgr*ԴmByI/q<`Xx$fgeICC68 :TCZTyQCaGX@`("\U*dx6.ё@e> k=fڌSȒ"wo| Q{n` !*ib@ULhe(.LR qfkMƃ%34]x Zfdu`@t!Fo*jJ=æsC٫)'ōL MCgѭ_zf }>iVƔC*1(<^{a3~%C)FRYT& %bYDd,'^e撏gZ) \/P3( "/"IrPCeT:<Cu2s\رK-MaX4Xa%' 7 ˇb+H|jz,sa RSv}DhFDB0c5Ž`LX>xSG?e+il +lS2oŻB5}<;cg4OC7V# L6dB9-co(} hU&; =@%g־nbWA"l_J&Z$F͍+ld@{4LYUҍ[lA䩲& 񩤍,{~QsR(@xTN¿Kd:7"+^̣2h~<4YBOߺtL7z@[{TSex=& g\e՝C_Kv!z8HQuGͽV!q9Ȫ;T9l ;dp{Dr¸ R.Fȥs# qBR!0/MR.ΒbSTȇ4˪f(! T!2)}H1| wf t[]Qj*J7T=2 qadHe3fXriFHm{6 X yeš;ceba_䲩YatK\fj/ T`(4J:vPCI0Q?P@Jrd-yjT7CtmtEof ,ʒ^KPDT>y!E7/SqdXApw;~b y\X%C&F{24]w`:|a&6,[lU=,<6Yzt 1̰TFOvR!U}H@6ۭ֦yRƐZߩ BIAW[/GKфu ԌXEj&fתr!VR~! ngX4i[d4](-Ot͟k*?07/{`QDJBC)59U 1ҭEk .A(ù%5>~11ĥ/&'w(7cTe۽JDvYWrt>iGGuQi)qZHII#WGGH@h\@6t`)LCZX_Vc[Ξdbn~Ee Y&XMC$9"Ha&sfôhydeGEX&$xa !\zImxTV5%|%Iؿrgt*% 6]=GjטJ#2IM'mVZ.RwvN&h+9蹁/zw 33!;;(zĪ V=&dBH:$!-c26&%؍|]+iq[>_S=cDW˖BSy#n4*xo`,@BrS QdUoCk5Rt՟*܃-@9/1+3p W%;#Cͧtreo悖 ڎLp`G9HW1-5Cyk@'uDa#I!!32@'wWԯ/}Zy"fǢx4?yb8fu"vX+ōh9=vIǰz扠tM-*>BWb"K~@Y\,ㄴ,18[AY&~m4Q[%!U;*w)ѳ]{Cz֏ h}P#8s+h!Dk$|exAp)e_?u6Pg9d PvhQMRXO[ZD3 urYxI59^,޼huTWԍDPTMn& M?iyţԲw@&.#6..'|7K89'icE;$XlaZYT3UeҕoYWkQQ^amD$0 Ќz4J rRʕ 0e' g]}D-ڟy-'p(û %ijb 7@>k^^j3"vRZA\cڍ 9Yjy짊Wkbx\ΑC,? r!JE&o}avi`jյw$K]S/ ovOh4> pO=eCa䩈~Ymd>ݤᠱVK ^O&5elBQ:}ewlv@)kH6`/P8r$@}'ֈ*lB 'o\%VbFt ;|Pt޵Zan uNu)M/6HJT\3cmhY}MNn~YXϐBk:z2<Imln\S>j ; i/컶_żyݱ+ݾ[޸ye"S"^qE]ypED5u4>_qY^G?I{Sotpb]Ba|3^li=Wz8vuQ=쁬bCpahoŽe\ i"o{%v#<&8f.o>7XVm]_"/y9+  em?] ^Z҃զ|nT`3Ss5YF]i;Q?Q9|g^ӦyShpd.pbIeXEOdPhPyHD_%t{`@P*ҙE.-NvxxTr5)=ONRd9,u[H;>u/ E-^m~sƢqrU_^9}g5IZr{x{>=tjyC{*iJwUWp[ٙ'Yi:Y!OO} n[եܙ>M^{q5;0kWx*#^ <;'DqxxMT1̽:@-܋~h@~sZEX݄MⰐĹilv{"4mOGH+rg=2Af|BT 4RØx`bŸ?6Ly)g#<$\'aܢpǜ[­@2+* *Eig//NJ@.D csbql!?MXFwehr,[L8KzY 3ە_BР ** ,r e:Cwv#O;:L#j~oƹGҫ)dsNJHu4Y:pJ~%u*C s=G]qr6~܄ly2>^09^ʳr rr,ǫoW-wQNpUt4z[Lf5m |b#JUTDTc0w"3֏DVďu㾓_aؼC5<ǖF-ٺdC63 ?@w|cdGJB0Ch^tI2񬢟|!ٿ# Z/{@^T _535޽- MVMH݇7jendstream endobj 429 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2094 >> stream xUyPw{UDĞ(z Qr9 <`DDeDFQY5庖fKt7)mTmuUW}?^(L&fm`L6z/}!CG6B(w߯Slm#怚ʞd[BG'͙3Kz/V֩ի{"c##*u1a3&Z;4\o:fzSVup`: p}__E/ݽgy|pbLQ`ʏZF-(G(%5rS䓲ٍA#ʿ7m"JE(mCW1v塱!;ef0"D8#ތקr|M8WE``T*.7b^C'ǘ$)4آ(fHRvΙ׉6[l[ȧ9 s !*rsAGnE^˘{hRDnMnnn;K_qB>fwRVBgr[ɐȒ+W|ћԂ:`^Rݡ|H *KE89{\U8͢Xِ8)n3ϫʃ4`A"2& HNtG1piAo@Td(9(`PHk%8s#+/k21v=R24qڟ<= l)i?$uu-Q?^&!H;sR>uP ,F2/!ݡ;RZZΟJ1'KZ *}ئQE0 Ĝ ĝ2g'B<*AE#NϜ랶 HἪK&)Etơ|i@'G'g.Vx%xLE'0(0յ5GkYN/&__JEƁ6ŅDޞ җu"X2G7 8a.:8s8RYY:c~z˔+PVc0TMIٮ%y,% aϳB֬dZ-KNr>P1H{B<'NJ9[ҼפEAOߠý/5YHY&bVRA eb88eCn6ETH6Ys*0L {$xM8U3W#V~6$gNA4Zh:rAm+2SB&1^knImh=wR:on[}"4Dc\q)=|qFhmw|*/Tĉ9WǕJ~N[ >7%џ^%zZp-ʹt#qW7Yg9L]9+uFLߪ)q[N}:],GuEԆn;<0`Oa(mgHvi%lP!.fc  2ba / w* xK1téhߚ,w A8ٙoW"+quK/Fr//ю.o"KڟhwA Z DDs+O4i,}}tFǴ7ޚDOHgK:Vϣ{+?*=`ǖ`+ Q;m$ Z A.$ ӊӊe'f@=,*,/+H ӺĔ$]LbL_j|7=Pm+ǗC!ߵK'%OV,2SJ78M0߳ eoH8k AXaԱ *b$ :v Ky2rMY/7g_F`2 F!=e)v$؎>m2gn %+KM%&1_@-aendstream endobj 430 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 8189 >> stream xztSWR"ń 5$40` ĸܫl*d[.` b:BBz $IfM2s5o&0z^tos9!! /,1-$.&sq&4%y_4aƉ&>7מ9EmmSMiӾl OLU3gm{g}gۨyOCE u1' eB94Z-:"P+2nߧ2. 5 F\Фi\9Re[h79^TiL 0ujC -PF됊FV^¥sr.rг|9($QSہڪ3h(;.)'c! i0V|0N3Uv ZH4j=UTl9r+Ձ^4;-fK~.CPƖHq-Ay>Ľ4LᅟkNtqO^نv4ֶ+,bD2 [Zf(q=C >ih/~eˣXo%dB3ޝqv=s+eP쓼80Z-|Z*=K8?M -r2qۍ'Y>;9Г?u{c2.L.vŠtzi;%~gݱ.d{U؉h&aqYsZ-Z fB0GvA#NQ҆}@\v;vg[m]=-\˲`zeY4֦V#4͸HF=|y@oqeG蚋=`*]Yb(?2ASk$Z]?w]p}BK\KW)h0;QY*z/j#꽾]y ZFPfDI[+Z %.3}9y14uIZ&֩ty!0Me k(^v.dIP <:f'52oL*zkP`KԺ G̳p13zkQ"Jv& 6us*2M,H=Ute^OP'̋&=`8bki/":l&0=')[- *t.7Sf0 18_eא-q/^D;~釩h7v5Tg`'NoK! BheYBBLre)T־U;L+XP]^c0+xmTlsnJnVpvb^Щ" NS:Y.P.{`3Sid]A ""TtÁTJ~ɤ[Y[ǻ_20y{ЩhŦ</F5^Oy@X|>N;3_2| u,>XHk51Uh$Ą@u5_l:m4A9s W ;! bl1M4#;8Nh>!5®~<<[PWڱ-_ʮc,5AvNUs}ubDAZ.v"7zͫ*5C)iU)H!32L TȳsDolG;±ؚet+h5MbI<橥CF5ޭk2N_(dɇ躓s#a6D** IGm-t ztݛA`(Bqj{AT gb'#%fӇq)7JEi D2V@]h@1Yad ?}qRV ФIEao$l Z&j~`[qjru: #d:AшuP,9]4 G&Q#rvhk5+:[ځ|4$u0HǶR#i2T`dx#|2io:hb {LU<'Q7WF qU9j2qw" O ~ a~@*ݮB*]@ fze.RȢƛʝ1o$j@orD7rN+V[rWʱ3u=Az s1mqh1DQU]dp _>KNJ\(C6>K Ȳ{}w2ZT ~7{@3Be,Ob[;G\ aB1b*A[ϻ! (`92;/j o;ݎkgp8鸂7zwx5/& RT jG3г{Ov׼׼TI!Q r3k%UhWYLۜ 5mPergnsv'إVckmN*;NRJř8 ߝEL2鷵RMgYYI+.TbCIZ`czϽpX1;}ZkbM*rvHfo֏)Ub )YhriֻN)ywAxؾқwɕs=i,З\EǻT^tdn?fm*XÛd}_8el28He㦖J0?]Dz{i |Dm|tw86 csv)h2ڏ"Q:RRaQ+ؽ`]m v~Fv)7ho<0Z0^L I.a-?Z:;2!^=bӗxkK*3I@BQVh. ҙ/JIFhEbUa>J^Zlks9Tj E*q*ܒVE{-'|u'0M;gcیHq鿢:>sfGǻ熟nJ?L/.d*Nﴤi5%nH}*;S_΂:c4P#- Qa+Į0<9+N֖uo_{l¶KD#^y9u o}ֈa d<'uo*RU*To`b$@jkzZOZ[mJJM1_ًN (;!vճ/6)[ Ȏ}" 5} J s xHJceeqxYx#YRQIvO7DGQcrO:N_*W:Qzpm?75U4|??L&ҝgk8-_M_oZ$Jwbb5p.Ȟ24/]Woc)75>:F Ї WQ"xGN֊5y❴lZ c/iFe"Tߵ+>!0m=3y.k`5&(ʟ` Y'ǡsНPB!X_W[\F_A7FoFD΋agZ"{s~KJK%(2>5Axu95~JͯqŦd445st{A=RlEy|hPt&7ƹ8Su u:{=FaL~T:, :8w&SY>)>cӔf9Ďt"pժC?Tyh=! `# Jbm)mו@bIhC:f q}T=fh*";}v: Us~CzsN_cXdCV~C+\ Ać>qv9-z=W{ňٗa]=3e7zq<*/'NO][?BVF F`kd 67줾EFY`>upVsYȅ:'8*aưFVoBmzJJE hOp 2#5 ?)Wc/^I's UUz6W o:{,IQA߷9kZvP;6DezP;)Zo7PЁ6Օ .5b'=l.wP`Qqn?QGau7}BeS2k}] XH\;h<42''#f7.jJ * H IȫcT !GPBeEgq݌E>h$ P8D xc92ttZ[LVG{J3S*B+k1 }}LzGyǻVGѦw q;…፻wW

@W=8zG.t=Sx('z.S<04|Hpe ǁ V24/hʳ+Yel&%GGШVR+z-e$ %"nFIK/.F%.G]P#4A&6˕ށEhX7Zx'庄 9kL -*aru؉8Xv(v㸋Jw`gF-b&c"yYrLVBK_" ]KY{f[ވ G䩒}f~Dج{!N"L\;E&e׶OЇ*QE"5~[L\l\Z| G*D^\f{$Ru$8,%:!*̞O"m%1*I4 rVObj&e m}X,jHIcqai_PhBwDv\"v*nb咊̶Eu ߮ 4NSws}[ V\dSWvh448I9a|),:De5}2ɒQ HI/fH2[B3ьzz c*k\UO j^Ei(qT+I" AOF\ 9>bqoy`JhL 6(? ) ٜ{L9.Y쌙+Y&9(p `q>wߑgϕ+59yT_?bmcb 3<Ϲfu)߁L*#TN Y1JEM=P &!tuUΦ;ɱ׈)t[$uMIZ,P7zMD7R-/$g,Kr!M9EUr/)-=vOFN'UsLO΀٣_Qw9Nu`54Uf&5:ɬuTCqn$5bQaHQo|.5YFj/ſ[ Ezs9S9 /*endstream endobj 431 0 obj << /Filter /FlateDecode /Length 324 >> stream x]=n0 Fw70G%%Y2(^Cdq޾CGŒ>1Tq8Oicn8a|_gL)+|4/YqxEs,U϶.)΃ޖ>ڧft(ߧ;siH=MUZATE(a)P68Dm8`L71Q t0Ł!B:n!B"=-Y("=-{q)co+_dk0 `NsdE9b#fj OI2/+/:endstream endobj 432 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3956 >> stream xWi|eNp(tVAؠAVQEAb8 G!ttN79A k]APߌ8o Owv~PU>y8Ĕ$ݴysh$(ôs+s'ֳ?umO.L9?܃ߍPlRZS6)PTIR_tyz:HݯH}~IܼrYU(5,?uKR_*ᛢԴE S Sdnߺ6sk-3.^?w+DE*с\ 旭ZA&ߤج/R)*.)}z3+|B,"iDH'vKZb)XNl$^$6/rc#ǵ"8-I 7eٔo5'뤖ajT4ڔg|:3_ #bY] 2[c5H(Tfw1ӮWug]C_~IOa]5hĪ5h[|]h e#TZ`6igdf8FmoyiTRbLltPè>etb*3%}V!y t2xzmAyhfgي**h0X`$vgs* Oà0ŨYx&ߢ[B*7b`54F gg&J{407CU8\p5IֳF*jSN;,+(\j; 995l#Œؔg`HB5va2V㗊K{3n'Ќ{V]+3V FNa Ŧړ*|67D,14C=h{5l{G~3һh>- K晭5>pivR;niКVZ6!![Vb]]>l$|9l+d@3P## 9B6fF:}0 9dtqa_ #02Jʘ7fмxg~ d~50VfVhOOxFX4;O[h`%Zv͵ydL\ ;.NߨhTVV][ŰDeYEEXp{*:7t9 K،U)t2=eaR(Qz0ȕA9p͢} Dȓ-dj'E49z4YK*z%NSeCzч0zj{C'|Fz~ߍƤ&|-{+tFos;8u]U 5=X̾A=jZP}QV UdOn>v.#(zhDEU^-rA&˯Lmg<  ýڗ*t0Vgn{R\}V6xoe}#@~? $:w}anj=%z,%6|} d$46$XBtc7Yf;oG0nR9)f:kBcu;|x u`s'n!Fqen# 4 55Z-e1zS@?z&tq.qX';%^N=Ȅ=K/_Q!eC+ A @ph$5v_ KНZ /,fG`;=}C<i@Tqu1 '/hZted,q@,yrUuݽv8B@V|/=iSG  6݇x7`T6,H\>gCB^0);QuN|& Л) K :XZ }]op^5lҚ*UcmHSF\Dj<b 67QXAyͲe~"O sQn|\,$m hN{d۠crƟj3Sʍ@V"-L#D&Ĭ}TkQR:$ PfV/kߋf]ƆG:ݹgbP_23VwYFXjœmkʁYn4+vxW+pBƉj{FQ29 Ɵw`0Z,:* i?ۺ/C9{hy`X.욅W -G? ~z6 OUinm+gL_GO<v1{`el4=P*G:>`v")  ѢTΊO.Nk_B.Vs3t-SٱMR 5k{~[=N+V.}&6țO=}H~``7]jcg y!?_,Q #:w]-vo.غ!仈 i4UZ~s с.n 2aG*EQ ;bd:kH+ht͙nb6} 5'/$\[2r%P ]#nq>yuǒ&IEBT:cg\W;+D.tGAl M/ W4N%ki %BObSM\~O6*̍?7 UIJ%`Me\O;9ۻsa杏zljt@Mڤǧʟݝ?B6eyǪό~5mk dcB#_'\zWxC$+Hy/9hGS W7uGm :#r}8!Ȑ>Gr=9QPP`3jVuz:emW7@+T{>;wTsN]-E Q.ʱU*+"# c@c=WVfcǙ[tO4~7~%E rɫS/E݌^By%ܥZ7~*x 7XylvZp9>C#xlރpΑ AO"~@Dϒ6絫q*7>G,xmd{GW& Ӊ]nA,~!<: K=N'c)< N4d%h9Ƕ¿ @hqDY'ê 4 '~Qzs-tUOAr~!!A%M QV~v1Ov"}❑ 35>_Fyi#өiSmI )ӣ6n0MA[-%փwa endstream endobj 433 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3502 >> stream xV TW֮f*QTj$jK".#Q Ⱦɾo6k.6Y"aT&%#%q7yE'B?3S{~_=B$[mc=%8$)?~|]BODzHM2ASP$96%KWJBB-Y[ϟ;WxZH-,?IIj冘a3rfLe@p6˘mn[,]?vq\u  aALOem3o~4ce3gym0 •p#‘@L!Lx` SŒ!̉4%&RˆH!!Tc T?X,\H(΄ Z ņΆFFFs2&16Bmƿ2 A#t G!Wn6#&/f=G ~$y,wד>2pd#I!=t! ZG-trwg+}!!oҢ9j~FUxۯSIdufs%`wfG"bϧ-j ^G8=N?` BÆ;DG]Ib@G/_2-y´F98eHg,+KuCt͵ɤ}ayY'w,UB)YGԧh*ZY!"UZ#(HSzzbxԾ֠22rJ8M7B:6*V]T%J5P*/LV^#@@a`G꘽Iָ}E]p3m-> 9vV^(T&J%،LbU@!E=P<c^.SjQ#jk(pƔS0']IWE{,Zeha>[N" A@ Z4$'+1&aJ#*-n{ʐq_1UG>ycψo!=X8>iЛIE&xؔ :K)l9>gv sctvh/ܯ0gĦ؆}5)tb)ZSjpmr? O_/I13k~ 7o^~h[N`*,".e#+jQvZ6}KFl8ehai]QBfN6wJd#kC88ǚWUd<ˆs[X]:ҵGЪϴ&/{ϼ;r`Q;ss@ J?"k Ss$\ii6B6\< ԽOJ czd2('5_Bk2xF 5rn{O_9.wZޢS xA:DMVs$3LQ$B"W;(Y)԰7;WVE՜ kpꈭN~ !{QES|K|e%iraЫ0j!2{69RDC@n+ 'HCLG?~ӜRL$ boM0fSLxh3ISyumh{%\ =C<%{k0:D xzpBr$BRWRĖWw~ @]&ަ Aty Sr< E)8NQnVilLՄgzKz#?D4{޻n]S5?b۶x$*A;6慩@lLWW5{d~ [`:D^B@~@f%䝟 j(J7`uð^[`8ukBV đ1@}y:T ~(zx 9|bp;Q6X԰ϐr1Y!8I=!L[잸Xi8S̩]+k.lʹ$4FG'$DG7&46klF;P?^@Pp]k/waS-|zxMsBWIx?]3'0Wjz/]9y[a6.\hҲ}Q=:pNxB.uAjL~>mǏ I; On;{ q_SUcكe-5ڄ o#X4!>(l|V04sNq;pC[XESDED:ov%y)R%'RKUPil\\MlG1TY*+X>7GP9[\P\~d̻U\ݱ`쫇퐒R UqU-I&=,}8n P{Lew&"zrZ}s@Z  h. MBS*ǹQ\՘n:YXWpex ?'dP%E\GGiB^1p]&!}'4i^^AA k3O/&dl]w?G(ҩ@o\sEȠ[aGx/'n4"ǁ[Qx7Ԧv 7ql,jC`)qt<=/sf u.-"--ȣꏦ1[$f'sZ"<=rhRψH-^9K{VdituyY~UNC~SF6>]iJA .F~x>tW =|[.e#l`A`{ѯZ2wFuǂn<`qlU)N LQFr?~i! @XVQm Hb|dho/P;@($m %6Dn.џgSdda#}!N89*%';:v+8;%R%줌]^k F Y=77_ `dV*TizU q%EF _> stream x[Kw6k,,=jg8ؚ;gn|Ԗ8nzHڎ*l#$P U_}UugiW_'= ]N/.O⛬ʫR4eV)sz;J. ]2sB_œjgqN C_OSij̪J\kUy%xr?tI+6JgGXǙɜ~~{ek14z[Y^h٢ CYOᵗPY)n{I6*`JI3M&i^|U?" ڶC\L!}%NQA6}m5J:AMUU,~؜{kOBZqVZ+KQw1ݚPѕ<~ Ck'c`:ekS&*Eo+W-谩aJeRyh̯ YƅCاrr-6k&m,Щo}襌61gT>ݔM e9֙(D͑:Bw @6 yQ`y)ڷAQbbZɂٗ7 iětA*O:h T9Y8Ia'QܻJkľOQU F|G.ɤԧk`n|DԮAVXos"W}>HH1e#*\/6p8Փ=YVO6}LM:MT5V0h||blJ b-EDt vDAo,jgJ&PD#:bݱ0PQwӪCl е0z#P2$ XV ֕ص8/-? B+׾26e㬭x%݄Y3q.Ozy9i@ZkSku&+$W񌅉Kd=V<(؝ydQV1"\ݶ>C5smC/5Y瓚|=~x(K!#j3_vZ&*R2+KsjMڳ i8&WJ$ReNT*(933ھyֺXfk)Da༹rLYVCJA`xkThKMbAn:S|jB$ށC{=C :)' #N5+kah;o9L̜D 5]; i L(1IV#-@*H+E䇊Ԭir*d߮Ֆ imO`zɔ/'LIf cBriuh0|Gm |R\d%$w8GQC۹L`>՝7I*W9*#&;nNtښou\aOkVڕ7o yf"ΎB]0!TB@[bMX9TMޥ'Oӵ|͔DS=?=gEUTMKv#AQk]ވM5̸w/)ղ(tHwlU(GPlMkcJVy<| X9"×+\"VCϘ}}u(vL;=+Ż$Ww /ibu v +nK'+gj*&U!ʪe1x:.~XR6X5cJmVb Hk``9ѢxõpMA9}Ӧ,+?]AV4޲%50E_`sf{7`\Sa `Ö9m+VIBONȶx08+M:;JCZ_Egh@s^Y@֥邩MPo0/uDrc[W+CѤ 6]+ei=΂f+}࿣jHgT,5s}} x/㘹# Ry' Yhq/n䎓Ph 3R'VE=)fB b Inlx;> c?@x/5\*'7W195tAt.~+O>Hz6L/s Gt;?dg j-ņY@=YdВQ3a`/r~-b:$LrzEfPL^ L1P eCyZ`YR*M7 )? (%&z 1 M.\~0#S|@yDwμGw*fm]4D,$&?R8K$ɭ7v~^0tg TO|)"aEaٓ>.ny~$b{[;#@YzH>DH%gHv _1tjM! )ɏV<> stream x[MwܶkYh5=M;g+ѓE< j1a7?>*lͶ IuoUA?>OVGq{[O^^0x'+\.'V۬j}Ĥ] 4"+WG. CEm{m'gik ^Vۺ֋pCi6fSXNc|tugo711;7&o L,ỸVsO ,JBGϟ_{X/\$5י(e:d%=* KU:\],%NA sNUWu뺩z @`pٴIIVS?>X?>){4bh @xE׀0Vn<$Z hH(h`n[oɠL#䬉ou\ DO ?{gZoi%\kXQ^ess*V"bB؀~BVGj? T*gRcSFpgY6-$l9Y>jD%%VVwW Bͅ[Hہ c(פmm0/i[Α) ;r8{m`Q%8pʝ^v [?wX1I2L=hm4aĕJQ!;%G8L P2fJXS*%[hvYehj!Ahr ayK~ ~K7` ]`0Iyo~%w[ ikc? ' 39㥢'аH֠'6L^DU]x.>2#LpNãzHa Vls{.̟-{FtiN\V$ d߄vHj=qc"'e\⮁W@Z ;6Ж"*+ayBalr'wC n3 |j^UpȽ{r~%MXIcK"8 ,#6wB^A`q ,%2p;rtvEU\c`>tj'#?V39<5 TN;@do'yȌ*)R[3Z-JӮcfO gl%{tbҬT68fƙDAlЁRY!N߶M_B8ZLt!'i':XVJy̵ l6Ag5#8WPhKOyLȁ۝L\-4g̔VFr\ULMB~h_H5\UQ6w"|TA4v Bs4@ۣPrEHC O|K QJ s 1绣&d ȰY%]c *T$^ꦦ7_ 7q^26:CTJvQţ~=0J@,60h*~qxwt3BAؿzsvpSP9XNZ8f(yRx{37'8s.?pK*TL*y˜FZw*)z1$_ԤIk3؂Q2: 2ձ!%0t{?D2t-|L ?B1Ie0f i+vp|σk6u'Z5 iݧV_&֞H;Uǻ!m2se )F!.'T~έkin0y:=SdzSBicŃ/HpV{60<8xX _(=CHg٪ڥǯ0{ok0*,A;nZ6Rai/'j nyoo_~0jtc.R. 0L*c/cq"Zn_`⽿&1Vu v֮cZe=l0uj(~`:P&)2Yv@᥷`^Td z8h4};Fq|+YT*M:*@TA $?dԜ>T]H|v6qnW5n+sX]@+Sx"c5y< )LN8 stJBlqO$DŽ _G}a v΄%oNܺLD RQ"PN pT2 eo-;kkBeᯘNX7x#ekq8J9endstream endobj 436 0 obj << /Filter /FlateDecode /Length 4425 >> stream xZsܶw-6- M&_$ّ'Ŏ$ff,1 8e@nJ@h?_GyƏr_G7:;:>x&+]8p]/tVjR]]֋FYZZZ)z6Rfy.٫*nV%qhQJ1vVY?.U;|/7{մHh8|2,]]mlJ]Ӈ[* X(\qúj?NLDJq^0g̕Gs J2_N*rp*%,50 %`U]tǕ\EM  ZL~?,MsJ#,q:3  +YYΫr~z4wכkںZ{ڲ(Ե/9FB%Tn0_b<߀ y42ӪnWGm~ݬi>0`Ly42S*]m?V-(P{}: FSlߒJ[YX}/}om[\\N-,ْ0EtIIȖ~-m+Wmeيrܭ6Hԩ,g&2Sؿ>z:+A1ɷXW7&ѝUm+3,899z{!8|!4G C ˭ ( @Y(ޑ\-'U][;H`pmuoy"'ض3 ME}&^)~i ]mM G3]7"EڻbcI6x詘Da5gm]m\Q`SG*;&;XEo |Byćtx^M;5C;zimRc9 k웈Ɍ1L)1\C,yYHg\3ýalml dg-`gC8(i< m{o^%/h0vkh EMi3LL&zt[r: ސE)m>)vZof[kW]j*8o_f;>y veHMێrc76cW儉oKc܀U]3^a(]=\|Oơ4hߪX =G }DgJ= MՉԬ @ J,/!$&t{z䆽h+2H֜PLFqs6;@ xecjTU]| A\ZCl>g 8&&X J VYz K20^~l07b _| p3H9#a ,C%ɳmȀ˭HҌˇXxz}҉qB2[,qqu:j3To-mRWT֟Tf"l;|f L* /h_>^ҰG<<J˻ ڽ?@V_Rs'kjUd#HY!oϟ;){7jݷE5jjM㉒~~ҘL*ﱴb9wF*`!0+^<-m^@ױ`V'^DAZ[F\{ll9QWЗ<},Xwc=85/(͕qdhy=+0ߣq8rŝNv ~M/o8}$ZpQB.%!C`B, vZT5z]a-J $Hc &_MF`CF+2LYWּ͇%K +q% q?Ub.z􎽉.-jehUg~Nqxal&^($eJj 8&,D+.ⴞPuBQ-0n&t Yh-,+E z8wg?=wIk+sIؿ}q1ԤI9wP';Liat~ab^hßi, /i{KQz%ĕosiK{:͂3 kV}_֕ \"GPn VcNWէs(3 E pl"h=rO,΋Id4*aU* E`D_I6FˆҍtHY% c3{[o!V]+k(JO2KFc@ 5U~JDQS陾͍$~t?4;J# Mfӵ* TvАǕHIm GV2L'iȼx?ᴬ77hҞ{+3HQ!LqbZ{]%KI/ҊmUiX|X}fI Sʵǡ]կ)^Vz>5Hv m__`nhET e^\t!O> * ە:3PZB9j9U_]4MyVSs+Camd GlȮG۽z M[Z˾LeR8 m@" aR5<]x13.?^cD^'AM?ɑ&pH"Ȓ?X<`KK>?-,N_nZU\e%98"0lTb\2r wܯ b%RVЉs%M :뻪uc/ri۸e!ǎouzdc_6(+a1^ JDdnfER^MH5 +{,=-@DU2l!kd) @sw "yGq&'p!\"SVPBCeڑ`TbRĂM!-E{T!M~b8@*}-(}Rة*@6z^tADf*a ?67=&! J.htYFCuP>=fyz./=Y Y)maj0 1*rΫ5tpVcOW:Tv|fl'-f(Z\ov@ԌM vC #,niUYNqhI>{<]=aOYt0NPJ=ltZ |kCcR1 3+Pc4^i On#iξR#oq+>&iQ%{2U qvӣ]bQ̈\#~S;ĺdp:AER.J~Vp Bwݦ.ZEs,p$*ݑ軫pl;bQ)Ae⚊jÒikҕx-07(>w]\ǃk\;$>[{/hk~J<ݙmڏnzaϒ{`C)4H 'o)z<&ƪ)OJHWlnX.)^(&e#Zb7xWҀO4{#깎z݃aow#ty'@b^ [2GQF'Q.*i]wLmtZGы=B7Q%@ ~KP{3pbw.Ǧl\IVJgR+Cf'Mė jϓ^_;EJ]dfd_ /*Nugxk]d'_k-$ F9Hz4 f]b2euk0z@PaH]-k"pRA\cz'3wc[?`) {Nڐ> 0H6iB*3BJ,wv&V/=;[,K<'`J(N&1 uP5 ] HWo sw,+h_pZ.q(2GJǭ=RpX# (O>պ4X 탥S_>'Ƈ,p̓p\>a> stream xZKI9J SK,QUzYd.M}^X6?#tσIk-[4 ?8W?P{wMqNfrCׅh!B:3\&I52 ,\ܐb8_-TA\eTg&t0$68gQ,Dp$ɡA)9ݲHK6}WPM ~G/<0'g=%3ߨ=Fl8-k%a G8%u[uU*sl|\m*2m'+?(XS?-݌=976 X?.y4v׫+:pdX#f+Rِr# U1`eYwPbiA.]<$71^VFY_Ng;èLQ P*g }d0Y |? ]Pqnz0bЍ|]]!,Fk >gup)잿sriQ.tEFHFnfZڽrɛϩ 2dЫ)FD8Y[Aɛ>+0\j3c975f8Ń~trrqNH+7zX-A/'S 3[۠Vlk -%xi'j+{vYPQNkumWĩU?0Bi7)BfH y7~e}29 Ϥg~-%SU)@nu̓Gx oiAp!#<#@XyDVy/M#:9tqBϩ*i?.:2O$Nk}ˁN|HȒ:1fclJOR%D&QݜTjW6HDm=qGQ᠜o7i{( fjVEŔbڡJq k+V<~$JOzk{\v#5.h)Y_饇Fu\AS[#(RSȩ,^nJ&w81LxǨҙM"~]& s$s.W7~B@IPcCU6pL’D??/ym'wfg:Yj2ӴTCuV,y[N'.T}ٮx~lXdb4X7 }|Q(-88^sr#V/i} $!{HYfW4&ӊ&TIF*~V6 RTǒbY٩;2oVώdkAl5y|sxmdgj3Pkwj.vFɒ Nw0jzӪخe~&[ @A*zh13U센t*n${q|x/=Q*P{U,&1LĹ7 UnmS]EWӚ?Qz=r*ȳ*vWqQ|p[5_v 3:Y#I*N-W*u}tȤ7Sq (w'@*;DG}7R (Q\"#ʌb0ѹe^s:)*o;9swr̾C&u!i綒~<I$ۓDYk7#G@-D5"eYp~ twq^kW8&]\# }(WtV\O̘U}!ȪIWXN mmךS./G8' _p_doMa~S-a\me My Ѣ,e9`mY9lv.WYh-8/ƯlF|2:Wc~ +Y/cg]`Jt[o5#4 \ai7Rg*ʏej/>_-X$\wy}V%f*h \aQmpJcT 5U͡_6(Hu ^5]6T_\e4+߇SLNDCHk]Y?ŭwªi}ϣУge|=5,H[̝z$;I|pܣ@@RiUX`Ogaهt֕TX9QE2ڇǏ7YuGUc^^l߳endstream endobj 438 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3140 >> stream xW Tg-Q);tM;>\bf)D !* nZzowB fྀ&&1L/q2HKL22s^:u_wo?F$lH)\0t",\?+GcO k0vM҉0vdYWRQpEO?MKCJBB'&-޽+341'%t}ưMffܜФԌDEZhnZԗBc_]9fK?eF`HeSR7gdnۥ0f&lcf31f;c0a L3d1f#3)*Lc='rk98R< 1fژv= c}9~YL>7W`{`x!ճ rl^^Քs`+CLBd2CS|*N>Ʃ!x%HPCIns7z]0hRH~N!bqmŷC8kDT?b;ngːɮNxss8Jg3r6\}QzFP|tKL QkEfDDs8=oz2-7MK6&] PڰJM<7f [ȢLIQN&%AoNdi" |…zWz'K] b# NqɟsiA4xG\$a#;l4*]> ^ge`gnSw2N:JI]ߛG?zo:iM M&߻TzZ3du$A YͨmQvkQRbr`@EM~*Xe(QPj+L-N3Km'r(kk .[[/ƽPquuOk IREqlSJKM>47F gH(d.1eK_ 7(e7%"2KU/Waje6hTC{(DsF#NO!\h5nɊ{5rYmڏ?HnXJ}< !I?V`}}^+|G?נ:'ACxs}U՞3payՄ>"{[.0VỗddmBj5ty{cgkd),3洵M?~B|-XjlI2ǀ="q\nLBq!\{~/d#9Eaoj[ Mv9EDZDQaPz[ɸQ*5+JYny%u2AJ_]=9:R6<2ۅmˇ׬5>sTːqhOL05쒸AMm[,L ɯFfAp'TRӛsȫRA6\hԉ_I{0Lg 5@"3$)z2#FcgKI3߁['8o瀲5 BHR FyE0tZܵv\C! gBWqڝI,7NK0XQ妫S]Eee:=xCir6@j0HvX7rW&yhL d8Г{+?i-z FVRW F.’턑󴻊 *Uyɴ5g[K  v[u_]GEBRM/ρYyqJ}'k[: @b..WՐb6+YMN~Zmntg\yJq E?>0[׊@Y/#AvN>/#~'eC& tyC$lSn^ߊ1Ԏb$m兣&KR'*wQEV:/vu\:zڥVS9#T]|:TDŽSe>dt=,N=I8 7[:s;8>ʑUAq0kc=cpw[C_; s zIrR]fnm\HMriQWWhsXLdz r'GMw>|' %k aDח$cr| xH1YY1?pM˥G! ^h}ߥn[5A_]e[ĉc ۻ sjmngim ]&d6fֆ6V#f 0MIendstream endobj 439 0 obj << /Filter /FlateDecode /Length 181 >> stream x]= wN [)CĒ.ZUm/@/8I҇s1њȋGpȵ*'eU͕xUXgpryi:zv8AY_Z0IM'HӕH()a)a)aK5 a m(vNk,.gOb_z_=endstream endobj 440 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 970 >> stream xuRmL[U-(6a^k6"Fdn6 Gh -B)8c|ZtHilq$-K KfLrZJ$=yQ1'JJbݡVnrz;j]Vjty~OMt+K׶;[GȵG4N{Bc^b7s։BQaʽWspzow V]8VPR z)z܂QguQ%TZ[#e'-yK?zrԈfgmmSsCUTUx؝M^5i7}kam*2HB0  AS~0ZTUfT7G+a_m?#7u<_ø3^b \-Ջ5#7DOR%ex(+x;sm?D1q.&{ T:h)q׵P OV>{^ Xl_{B0dT ~Rs#c03W40եYԞXKGKwnK`h0lK'J˳d%, 󴌛b#)y+I.%]ewFag3WR~1Zw> stream xyTT;Wʠ^cM#(*t2Az*ذ1E1jL4$}[L^~Ț=s>{>H(!D"cck+;wGBTqD8D|`nm ىo^4獁Q`72H= /`ysΟ=.1w 7cnG 2wcn=v\I>2.7wstk.k|5oѦYc֯ XFa6x]U5&|m; {?ig?]sߝ7?zE-dӦbY;gqy&QG[Fj eOM6Q(j:zB͠ZEͦj;zRkwu<ʊOYS BʆZDRQvbj%52Xj,Bq8ʔQf5@AC QoR(cj5EFS6$8!M0ɉ!34H  9=פJS?3iC١msnv]an=<UϷ =}h6.wޅj8mP?|,O6[8kOR=4r0fKl Lc0,C~x&e7vʕw}[WdX%@,`'4 1s3Gu_>si?1mRAZ“}(5Zݸr+b0Gz 0ﺟh- 5xӀ9qL>jOonwٗM UO z41 `q3XY[ʚ\x;-UjC 9,،n=YL9,$ (͙ F] 3zǺA : T"&z{)0G?Ch4JAQK%uZqNK ̓?ҝBҋxSq?Ĵ[*T[JSl;+g}"xl .4[0rPK⩖|/g(=*A?9*ր}k#\ȇ[ׇ8zd_+KGPLhl[/|zP1Օ }yk%50@~ xG9nFApoH/&GzH[j(W.0C`'km?sm!omb >=bDK_>hz!h*1wrAa$/x׈*3A4=wǦ >|_A bfH#948Hf4t::؂`o,Se?lhrWټĕi/ _8\S) WLZ[ZZЁVjGol>U|mNW+A9=9toh)Q^~KzTꝧ],T¶@LҹmF𢡊>YJ'#L:u> _"\ݙQaW{^QͤYxhfBaD9*D(42t˚!JwSm" +$r o[ ڒƼt妧W/N/ByjI k+9-'yvoCVx9]B3lQ3J`vaJC4vL{bb_wx,,j Fd3Oax4^hf>"_;ՍGC?w4#l*`WdJJbR  $i'(BPRDUt؋ޣ;8v`Ma^,a);|ޛkF'WW%V́DY߃I8B Ơ"]Q^٣ၮww:L5x@P$\?JKU&Ia;V"fѪߟj$)5/{VjS[Ut{2r+6)`дD j ]tDfֈMȇUVm `7RO;bW$Wŷ/H{h 4@ 98ڈmmh>T-T72ChuM|44zΣ+zK-]_PXf@qGseڠL_WjkT#yI稙ߗOTب!RQܳOK7a 'me9R~_KJa~M.i5NxqfESv4%f2&esSNFDzV0{EʼKVBFƇGŊ:W:jcaWٕ=ӭ 9"f Q(bvRllqZ52gg D۷v XUXYP&fדgyZօcΜ;c Ɯˊ]Ӧ8z<+C FhHQ+J/xhnL*EfytIV~[-$L,:V^ޖU99:Xs+U!QKҕU(,9=%#Y81ȇ~)şF9ԅ*:_]uƈ뼭h-U΁X`7N;nńX+ȐĊg\+iFKRFщ>)JUB1a<^nFr:Gȯ§̯1 b>!G¿9'sU}fh5ye^,I2OK=#|KS:œj1Z. ˫CL\֜ԀqfCW=Y^\ZކN2;O݄a%}E뫒#xͅ΄ V,[AHؒƤ ;h)a7ڰHZyZYZO_e=VuvqkOy>qA<@S {[4tDK@H$3F=3ݗ@?j?)bQ\ϳ:``|gǦ/I )g &뵶tbUJt ?7:NHv)lԵWؗoR6>c"<~ՙc=X:{TNz͓^ .z5l=!x T|We6cb6rtb}YJkٟfGz)eoz)AMqƃ%ၨP 6_Vg[;EgFj>}K+0ŷd쮶>ُ쳾 廗&dր*P^;rUTvp));xz[9uP^|*(ajNU >>#bK`8QSac4i?L7ڤÂX`>GezE=IWwSZv|M0'}ő>pޑlK)JH<(e~ J#gV-*Gd_~eF9:qx0zÖ-Y10(>/9qn1w,>RlfwRaqR~JrSm_/3 D TzBȟ f_^n rgj*!Q>~HۧϴWU#Ui yхE*/(DDdge͍(⢘Ѓ5֔U4U>%A7Ht]!*?·~$zr:%E+qCRKl! Sz{ mwka xmm%5F y$`zkմwb+(<3+?oh(Hyޓ=/'!k . ߳5`c^>]!W i3M\%ґD9w!n|1ctf%$̠re}]eYsǹ$1ǁK}c"ZٯөVqkQ1s_|uvJEBFtRi8J@ \`E#e4^mpCn+++hⳠfRed>a'AA{5 ,NZ_ZYx'<\t-[jbۗ<{sEVl>ałgX:u; jb_lեQ_li_I(W^( faYzTFh#CYe ^ y K@; jﯾiJs$l .&nσ!gΔugH-FeLmxeBSt2=c_~slxqZ Er.XC8)(Gq)(.q"L~qv5B~p`޷^Kt8+!īD<p-f` M&:z7'9~lRտO&*KAܢҗ~ q+3g7; V joH@y@ hlL Q'$x4׳MIx2ixMIz/Ӵ s8׮ei\yT2$1*:,#J0 /))-sJ5[ *zf8?An<?Tɪ66nڟ^@.endstream endobj 442 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 553 >> stream xcd`ab`ddM,,IL6 JM/I,ɨf!Cw:<<,~L*={3#cxNs~AeQfzF.THTpSJL//THKQS/ f*h)$f$))F(+kau Sf73? , տϸw&C⫿k*g.qcu~.]RWW4f%+ȭS"5U:"?igX%V)HM=pHըmM3gM'́E˻9O+)ol-RY)YV]3Ї%?nB7 30|YDWO.).]d%+~7{&޿Y]KW7Ϝ?s܊3X9C^gC@D`dG~O|_fwϒ\]8 4-Tsy6~Y)WiӾ,`[͵[%${eoOoO߬9S{&lg)< -endstream endobj 443 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2278 >> stream xmV{Pwv]AY#xmzڞX:zmQpTꃇD $ !^RH<;=hzvj=[{wΏF{W~wy|?ߕP^D")|zBڔKoIHK(x {Z4)x4gS,?NI%E!Ei{so,Y,8X ̀~02pjewԹ1"s7o+]c輽5q#A1^kJތ%*};&+"'@q\7lWV;펽}fpЁyP1*P4WG6LDoMwZ/{Fs^,J&E7|7X# ŏ] 0WfqgWgdBkKXy=@L'("(g ޼6cML6g٪[@frK< $>.<*+j5Xo;!of".Y[x Nd=W5,L䍼b / v|hȯvhQ)+] PKI՘;`|pcI͞č|QmE8 Osx+B]Ѵc_oCY^g@y]> stream x\Kq|o֡}RŮ-Q]Eh%9V7ZMr8[nw/ԯw>*9xt7 D/kŪ׻nuyoW׻7g_|]/Vo޴^+g\+:ߝh^%~qݵQNt}XojQJ]oi#i#M>N4 =jz~/:tx,d?i^lz7+ѽHvZ]LlD) 9s֨bQ #k[{ Sܞzc5 _g7S: ^nȾ쨯c(t/a{ԾEnF4\8ey^ M~}1}*Fi`1G1VM^4fK]|wn[CAػva5`L-li^f%rY׼]Ovၾٿ *lKZki6ʵp0WZ{9WaiOGԞD ko+=|ݓ ^4(Sqs=.c9ge8m_%.B;P=F1cq2l wuI?(H8pҮq5 rsG}e_mRYn FȏC<2A l|뻟9ŕ!o!vA!8:4*ƅrdeY5ӓ| #[+eNHQ-<42(zO&`Rna6j11|XI 4{4"Ǩ)|z,.!f*tj7Lдݞy[4[rY;.Ar,UAl'ڣo^P\ϰ70C;DIQjrM0tVk0R_ ¯Q0V2~Z#iz;txHǀ&?eU\4OjDG*ּN] ,[pQ"WV+:j$1CSMxTM̂:}cJ"0" o#RY 8(/ $QŖhJ~mӐbOX*h0i|/Ե&tZlimB亰- ,J:> A~rK1ݧDSrcJ>qi'T_'7ѮG떊xj n{ urp@|@Qn>Н(cneI6|"F7SGy(2UyqIR985͈dt MHѱl19#!3b=E 3}z ȘmOc$8J%,2Q֑,kaA&S_fI3tA*7A 0\OH9br &b McEt_\N YGLi"dLVe&JiafAy`?_U%uLpQ^!T!BuJs";.ʳ T<_a8nt h$^EưxV];9 o°.܂?DA|?2]GcggO8cGsR.7 ώ!,%DcV)䔴@O[;e#7-2΅3EQ?#O!ѭ[yjJ&cv~Q1`hh1P$$ {Q[52ry>$77 ޠyP`ojfUYM"7!.FOTp.2D@A60)n8qu#a&a_iφ5N)]=4ByӞ'#oVbNUcӌC! 0 ˦NoXK$HLiCdwDյrҟr5fuX,bPKaSb=6$gvgƙnܟ ײ$^`%>ph^ZSSpw_k{K9]YUvr^E@x! v;o9ʥG n{]%%&r62{ݺX,\i6t&i>M3SEf U@vX*uYqDu< %y`*Pw}+0 اLyS/zӂ/ ߷^_Ag &ZA06aw#6TΌr݃8kbB=._M!(hl.b'Q#dgzheaA 3"|[jձàY؞qr޾/ٍ>m⧄6Wn2>;>buȓFChF6ٴg 0~ Ks{".@jPleDj)-3TYy)hiy!y?a-ooW?Z-[T]JzʅK;o@NMJ"fd,NinaVINKSL^YS{U &?NP m)ݕ"\|tꎷɕ&&FAeLo?o :Ig$M x<&Ke^# z-#6Op++*/ÞW vdf%ءj&n%Vb=. PInuwn/}th}&(dLNKXXl4c=z] &WMgӟBдپwѦ;c'+ჳqxρ}-[L>wT|%|wendstream endobj 445 0 obj << /Filter /FlateDecode /Length 4009 >> stream x[YܶN!yGN쁉()'>@iW+ʳ;HHSIA$h4WUO/OɫNOW񿧗OO>[WN'|j˼ԫ˓FO_Zg2iӳGMZ395rXo9=[ߔkH2 |?V>Fj }{!5WN%.ggG;[ y O,jMsuvKzʍo7nr@f,n-AeFf[rN?v,[.7v:&<Nc}w_OS89&Jy H10ɅEB 5A8}]h*.HhdQmdZy:Ϗ7nσͯ\*%[iFbgvMYHlVJMVlai ny܄5%5ń&z5X!5x)sø5Z"ZeY\Yg}E>’waII1nTkըx$2Wi-(*Yp9prj풄>/'Y:HequLhp8`RA $7 },@Z!Maҹ֕ഔ`ɣJft̻a;ov^n| wŇ">WVK=ƅOe!NݪaU">vV.]}U-( Zmc>I&em 趥0׫5Bl~"jVk w{_h+Wՠв9C;@Y)bsf> lu{!p1- e-u{\gp_~g| <2wmhk-ե(e8 5#.mrIٻ$0CY, ʃ qLeyC.}acI`]E@&Qn3rK{ep,nx5"@&g lyFJeNġ&plnzeٰzȂ@)wmMȧF3#*1h&F}Zѿ  , \ß`\Uϰ(Ec&P) Z΢rN53Ն …5b|ɳuE 02˄A\2l[|Pk /^§M!&:\v&8҃J v8]LR&y"fRދ/CK7Gϝg`\p7.0(^0wW\N 1A5C1TB6,^U\0s3JϪFU<˘6K\ G-w¼_ BJd,ۂ/'̊`DM{즸'eoBcGg um[Qwՠ2W-oqk!SaGԎU^B/kdyyĄ11J \$ ,d*ɪm!]tӀ)EN7*ePNO~< euߵ.g 5_,Uiq;ofF5|aT LNWt(ߙ@K|+ʹy9O8RwuC@ x3tISv+XW ]>i3rԯ҂/TPͥPUf&CꩀmX-!H,7"a[, imZSмQV#9uṞ|mNbKC)\\ c#,92ZI l88|*ֱ2Jq,o:][/u#)>fyK60i==uwX ]K!0l%ͷI*{/^F4C3a?_c[kF#m}ymw}.7+cLV3E8:2{H1c6rL=(Ymv_m`0]:ɎXJYNJn-2+]'hmegr z,FYBá} qTd%d\Qf޵l7/u#QIbN]q7N`bɹ~M(yX ]>bBY [U.?]A9 /juvpRH3|2صi5 R^o؆9FoAj܆@^Cr#""vlG280©K}Y0F23E\Nl^OƆrqqcP?d[*ƊR: -%VJNe+~hnjaD84}kB<QژӉ]EiK)b8`RuvW qx _5\p^o[Z >ɍ2.UucUFfIۊ-sr^h4cXe+!=`B6Dy+7L>ԙdަŰ{C̛~3 ȥ ͼr:k9}8ڐv74˾CXc}>J>Sv%4܃%oIi#+X6[~H ҁ &كҁ,EL:u放T*h;ui'U[J$+rH*(0_ӇM8?UXd$fRM!qOu=Ȝ`> stream x\KvUnoMqȉo\a]F&II~}`H$;!F=bѵlExq"d/slq̪J0ʴNvxrˮ0sM{oYmRvhf;l堷ЈA 'x~e۱/r=>лfO~$n?^\W,۶L7W.Չe 5susѨ˫gDc0d)%[,LkluVKova@nlvWgȏ.||,-o"sҩ5.gi5o⏰ ~ǺYgNa_||cӔ384|B7|[eq& 0:FƑQ7iX>Ut e3J*M&zhLüdE T[Udsn7U[M&C.~3nڸ.ƥ_yi%7$j ?7l&yme6AWx #J,"mFG?̧2-fJڣnոh/Af~шCFM <{q=l70Ͱ,(s4g%\kg!8'X|ӼHAAe?x]϶ kCzrzάO'qC#fYfz ;&G7f\JIE fȠfN7ĈepyxܐD@(9m@T¯m.ר ZD]*rdLBw𸜥$ZQ8 ԇuZXXYlG8Yh] w6ffgro}5Ĭ5a l̅6 ZAN/ A@XAgYޏ˸X8 دNƏcPeTZ!zAai"#`~YhLk .0sBTeD2`*ž>qWfʢ:e,ڃc tH‰"m67'jc과GТ*jӶh+ Bsm.\,Ӗ)]xJ ȶsNrexu(nNKڎҗaJK(i55XU2iy!&2EtZ`Yz o/D}K., 6gSL(bVJza+1ky5 65`Ճ[ll6iy .ctB5b*zw>S&ofzG]i|Е{%SQv÷)384[6m[)MèFj.U(V˛׳9(P HJ3o*2(0d ۨ:{)ֿ AB~{,w!U2LU_3k T9go֯frBL*)݂u1J147/]hoGl(EHMgNĬR()N!B +Y^0Bԅ$9E%7BCdYri4b6-?93>Z6cQRG>DY5y%y+DN++a#Li!@Hۉ!&NC"jٜ168^vS:!fUF܀'}KWxi@/H~(JMd%a3ۄώM=;*5 ~X1U / ğ&NS _H?'Ch94z-C1x&V4!gsW y$;(es>0g.pxd_EO%>-n%)J>Vh^ALzs(3%/*QX}V]IBLHbU 8ʫ2te!` jHUeFwZ$jάfïU|0<8ʍano!} Uym:nij̜S{䶒{-Ng3&̘Ȍ$*5& 2v6v-Yxޙ{D%D (%r`/8hmHQBuL>#e^lBi.уwU]]gk)̢c)`e-ڐXb%4\RBC{bS1)yHRJc>a=>;$'+ӊdl! 'J{yۢ؁?tC7)(FyfB9|ŲK^xŊ 8i#Ddub\V_\~)\刘.|mzڎdE/Zgv0>:omsA*TW)},/֤BppYffRU׋7wj YϏofP/K@:EI]۸d0g4HW7LI],_j6h)/rO zJӨOxѻyobZq' k,R;sg! ePw)RbcH|/?0 >0ɨޯ*(Kzp%i `WzUi\+.׫F`aNU`"KpV^n+(HrB}M,0D %&T?ﶛVw\W#&GݨxԅUW!-QC v&TS__iE.kX |}k+*lXU"Uj CTDw'5vYV&7q-ބ oCϒUְZYjB&tW}4k݄ f?FQy m~?0δc5uendstream endobj 447 0 obj << /Filter /FlateDecode /Length 5465 >> stream x\[wܸ>gQXNffN63g}%Yfܭ5_UD춼)P._ΛZ7/?k~9&Y}뜮pq)]4Pu>DF mM誁>X~tOcs8q.Ri-q8Rҝ+r+a]63-;/$Á)zgnovb}Kgj;y~տ=+qPp;j :Up ұq v]#2֭CG&R6S||-sݰKM 6>]-͵`}p@m8N[M~(]xxNFOu F \B%Z4 mEp@4JnG% /Nw H4>A#~w#X;?8Ħfٟދഅ-v( t cxe? )2 L!Sr*;,xΑk~?fBC*}OeJw<<~. It=Ҝ1I%IP;E})۴Eʹm<B5E1GZW ]^jwLSL\Wb\KzUX< ݸxc.[䣎X `te.!C{B_WW?'^&ϯ/"x UP}԰GեZE>2}hbMxۧ>rn`kkb0:4+xYHF#ڍFWtUz9k0!? !03djY~Ahmp;5̉2LTt# ;R z >ݐEedZӀP>Mv!r_oGء"cd, tǰ1nJ櫥pT@z2 40韏L*a8-l N훳i-nBLWԂXȷPR[ՀW@ FUc3ԶmeiKSa@Sl"o?zTD씖<E%] WL;0ƉIspKZM,Ғ)o6uu߯G rKv*ϥ]S!_H_8t i&jce1,,>.o]}e 2w5Z?!p|x)/&5~G>H6)^ ݥ>W 2kc`w3!7쉟wb&' 2b|!pi8;Pc^ ۵:{ /팮֢=\4SYM0mι{ƣd%b64ZnEo՘kv$ mg $>,{*RJiEZ(O:G>]67y;FI"G F<óq_%̒pt^]2e6}/.4<8MK+vd:|c2 }z,;6* a7#+((6H (ב`̻[:LϏ#(jcչvM`Y]* ?kQ?  9:pr(~ @w\΂4mxdgҍZK)ƆK lfCb//}G~Jأ7>55^34C S>q$7\FD75^ #R( ;.Hj[>Dm4 o 2mc.sXz>,qZV1KTCA]wH9r;@(UʜYrB317^h*B&+j"!%Yr#yfH)Yd88hLO%,J)mƝRg/#9*c:C<fzF RP̐~@cuJh#]ʨd 3п~Hƫ rGvd^aA 2+)$K1Vdsw*nѓʮs_QX2JݪZs3%(VFyPmba{%_,zVZIN.YkhrW:[\[ XjcƷa؞Ò| s1ب>DMRk-Yh 1B} LS6h+4:oQl%_%ydW\fR?y DIqQ˥JWRfC5YpO(>8GKN |:uXHH_X<]i)JWRY8?FPHknik۪%z;]zE615Fy4*.~>щE)ꎧyʺ7a V5 㕢8ne6Ū8p[A{秔_Bl׀%j̗c:+J J+5 (Wi eǬiL,BWTd 'C}#(*Uΰa<*6cZ/Մ$;2*W楖Կ^lfN=vR<-C!J:^* FII'UŐ1Ph`c( [Pȭw\)6ТEB i|(4 JFU+.qOQٞcI\>ve=]'~g1630HXLl`9 8Ge+6 $hLi*IA Vq/H+qsuHŒ+ ckў%)V,hn *aLʗ?/Sj2XGU< %Կf@?^~xCu:{]fnE4S0s("j65ڦi4eF,Xv##xI9tУ>H7~H$$)vTҶXD*XఌN">Eҫ;mQ4/ qݥ&+FQj[E//{?P[x"r6G`Z=647㯘8 uۼOW 'H!ۅw @rQ4b*'XfU<T]cX_izK6ô% kaY+$Ps-(ɉ?:"x MGƸa|~O)5>I;q>sObk]q#8+p"NUϳʊ&ǠOZN&i-zkHh%1 7Q> stream xZͫ%G_(Mt/h!u~]a83 3 =yyyyB \1;Ep' .ED!"Jϩ}$뮮:uΩs~wi4߃e wisL'{KOr2+(J`&]K,rU:r-[EQdy^xZJXL0,#k˸Xf9g_;sKU)-op\jºYEB'ͮ5uצT%z}҂%fm7_t'|( SwNjr-_Zr&(fJ'tkLtw}NC tNB_]/j~$|si9 uFc\8, .P:2V nDB\I.bTEi\l5poiJ>:TŊCu;y4j~r~PJllY?hR\Zŋ4SQ]` ܯ6z[l=?~UYw NFJg͍[жW>P/{+\Q4p(q6b3.y/TmYR;$45]  el B\O8!!F6U 猠`рf9.݈pV ڢcj2ό 1zM j,lU]@qOM]CqjoQUac-̈́ \ Z+>&'e5hUC52NIJ l?ujRZmS̜L"E i5dwYDx?,4D?t22߅+rprSeBX%yV: Tcozmy#ŀ1\WA ?xXi!.]A8ĕ('CO5"҄:5\ 7(F{Mn]fCn͝< x'0Z0Хs=NO_;v7uذv74m܆u@8$R^B$@TIY6e vU;3(;\_ 5^C炑Q1` jKAIR&d\ m[5A–+ gVA 7koʶSo`z-Uө 9L w7~_-e=Kϻ0p>r`dH82##CQO t7Eġf R(nry=QJ #j*[kD&fwZ3޿xڊ:ԹRH![ $x KA8^ fĞpv͚ns|@tvI%{q¸vTx O5KĀlYm89BT|fgƎ?e[ӵ_U>qlߎfܭe+ɩ\#PЇ}n adQ!:%n#LmkwY]8Po6/δPגZc'\]@+*+ ?-a"poN:)q^Ɓ3lgKg &H.Cch}%s~Ry\C:j{Ol&=K凢lWvJe,gٶ@CN66nh>L[‡0z ̢X-Dz`?}lE-0e]N8ϢDZh0gJ}=Aendstream endobj 449 0 obj << /Filter /FlateDecode /Length 1842 >> stream xYKs6/ɥ`fNqljKqȊVI.P2M9vo_߮>#A4\ >h=;tfpo:xr*L#M&" 5i> aJ℅I0%`PTIE*[f(tY#Y5~yB#M,VҼ$%ť }~:x6}/p׃VС*9b3LvE$ bj( XXޒr.ʿQ^K2<_ՇNKw_y7<˿=K"-ˆÕ'Е{ qKo:kL7@8t3dD9%˻L+w_ 5HwGe[QԣdZŤ41)fiWEb23@X4-2: /oFG"ʹW f51c.juoC^H}a2*`*(X6ehQ&$-rRز \0g9Bc/;LJA7y4>~KɗԅB R7tyB%nfGbAQ(Hp)zŗ䤏y־3GF첥8/ )\t.1YoA!POeZ,珂8_Ӱ=I+٫@՜1ʮS< a[ ow`z/z*`C Ma=uc@aj^]Si5Q+#UM觧\SXfjƐIʥy(~AUlD&wj>3:hy߄/"l4Rd e'ү']6\}rrT"i<+ \Ho7>s= hv$ip޻>X=UCV|sBPހrӐIbjLGe2` :da!0l;RSZ1KV~=@/,"Oɼ@P&1RH0ѻplEZ3YFDV"ڏ?w>"f0D ;cd}{J "Ǩm,Դ)MJ-˹sHnSOzx<ϺZ\m{ pRCǡDXg@!bե=2Z71y`k1ĵS$+42Hħ%ˋeFVnՄ׊_PƄQEɸ3qF.s n ڴI~ou@M"MF*[ !'@q^owӶ.Bq~3HBy ߙofޙgQR:{ӳoZ]}&䩻sgz/nCsO. }we i09֭ (6\Vܭ FSQ!=7-1RpnZT;Kԭm .rC/ eac2w' j.c\Ny^bj7|endstream endobj 450 0 obj << /Filter /FlateDecode /Length 5110 >> stream x\[۸~uY⯟St\ŏu2iQ|e?mݾk=5θɧ߉v D6e-j5`6BUۯ1j)}Ԯ<7֣[ijJK!b.-3U|hz^tnPЅ!ʙKΐ<[r= yvvWcS5-vݚniV-'Mx LEr+]/,'kEXA0yQlewXqijQ?5vl~˘a V/SIwy)5|{o=C4\d`8`1 I"}E[ۖVjvԋG HxAg4ke 6-*;1 ,xU0R#`F d:1 gI&YȖ$˜$YBYN8IRA,oq]* vr(}jr^EMhK_m k\OY,0 9fdفm`G%@؞iyz 8n6Xta•DDj4!NvvM!nc(Icm_N}2ֵɽiXeۨҚM9O=V[` XhRH0BTBe=q.Qh*[ t0m,=а`l}t:a'aqd:djY|>9iVSlR*rOe.}oȐm5mp2Ă,jݻ\h=vqpb:n1]|H6%So/ky ,ɓK0 ,S\W(-_RX#K#T[Jt( 5Cׄ|1>7GJ dp@)EtR@x/A[;M=υ]Ѻx۾JB2AA孃LP`=%?0\S} Y 0W%'p =߈ݍ+II1vV0zb} _,adDCGkuDp<"9U,siM~s&1wYjf>$B!h B|;V5) 1񙏽=>ӤLT^&̶!`ܣCr -=Ru[^?,>{t"b VnjfI*Ҿ R}g(jY"㞕Ȯ(!LE.&QxzIlP>c1-C``P9R?RQ`0%Û'QN~^:@ڠ %Xkۅlc | ׇjBkD 3gʳ]W~mmHSGAح_C5OY3ٮ4hicnq3mD/@Ik/@}h\n㟲c ?={tx.- #˲[2ӌ/GMi` \!֦01:>Lr%#cm;֕JKWnj]J[ʦ6XZ Їq0M9ԋ4Ŷ4NJyhY6B<qGkH͡D^fmMuA}-Tn' hm̪;Y#d5K1jVNL& 1!B4lI4OCgb7ةJ&4ln k@wX !2ֶn24¹ԣՓCq6~є-dԺ&|*eR /SFOo\wO:ƹcz9h!v,85K,m,&4Oќ6}0xQ԰?^Yrj%ԋF`HWH9:g4Y3&JvU>GlwC4]ұdDmޅtYvH #̽muxӋ7Êl1Y zF_VSH~hK,F~n,'whX6 (!TG:"rÏ&QTu@!_N]N.HHs<I~Y_pdۨWwr7t)w?oOFϜUo؉  EV&enM_s%tŘd@7ʮ^ezyt5$Cҩ4R~ӎͲծ9\M;g/3pvmVL[ıNجYPrt$f>QdQغvH3;ɫi tbXU>q6ADK WW1xm<20"ؿ)uҕ',Gh)O6া1?S+a] Aߎ3$*$0 ޼ 4/ihxpn ~utŽn."]y؀B#m=xP8KCyƣHlй-=iiA:$Lr|;@i3y! ZsV͚}dS 8pPn7Tݤ骬oʦw7_!։hݚ74joJ)|GB>endstream endobj 451 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 7014 >> stream xY |SUX3ըT@@6MłCKBBoI4iIN+-eQ처F0 \}%:H=PCP...nBÓv%O&! 8!`+zɇWƢ1hӔK`T꛱q #<̞=wL{T<}v퉌%Fg,OX956swhĮ00π-6ܰsu7<6`cVľVʄU${KeRvM/t]xĆ}"7EENu| ^0qKK.r;f :j"OMS/QFj @M6Q/SiT ZAmޤfRۨYJj5ZMJ5OPKm( 8ʝ(Wj(%hyj<5A-FQOQ˨ʋZE"Ch]&\1zz}Qm@/6`sg[6=lȄЇQF僐wز/9am&C :eK^QA4.ٿ\Z)b[W|~,f 2nokf:_cI(VjeE<b[GK/ם=S[rm- rM&*i=0$}7]X{4`&ѝ(X/WÇ9۶#+!$hvȗP"'XOmEĵh{x(RJ&W$ q7̆?7i~KӧAj5h,}+zŊ. XbKl?_?MӍYËA{vjSs.VE$l2B;wH]-bU}VJD5T$ydr HՁΉMeMz'd`Wߣ$RY#A}i~ㆆ6 \E~w+Z\rq2c"m r@ /BֵFkv>e~pc.AnVauXq?(w c.)8lln x]>qO\])C"ux+?Oެ۹6lMŊJWtO mPyUյj9`&4׊Yl(ն pȁyC7l zD5)h?$^JcJfT4RJE< Dc(@#5uIXc}-iz0{8x8o %PejӔYI v-B  i)H CZ%2,_$׏F lmz7֦O ;}* !|Gvgo+yc#HL;އE8fRB}" @ؔ%!/?]2Imq4rf 4{׵:K9hB!?4rgv;[MQD컯f,TDJ]TK~3{'.LQ"Qxh î̭*5B01lTW>Pݥ y.88|CA1z mu?'=>I-4~ @7D-"9|y_ ԂG5AlƵ=Oi_QP+ o" F kM|ZIs\s4}qd'kTk *ud6L"O\$8rThmymCYAGV9iUP`!qmrXjucwwAIe8{`'r‚|K^^M~Y^)!O'J^ \=>Ϟ?h8cFczxhͶx@ Q ]cb!!y8i[&H6ٲY+˕vG'jL=JNkKDH !FL"C!dZ :O@-n{j G=pX m]wV- _hR²SQޫ5"6#Uj *PaúQb5mo_ Yz-BtzRGјQ aYjnjWp>FA$Y'^]H@SjbEN)Ɍ۾+ZNaHB205VDssexԟ_Bné N/ @~H `] @Bu n"Sp0.Q F%z!A Q"IU'` \mс3IF1XUPn).3̵g ,~XcBDrY@'ne (+_++qxNlkhN.Db ~Zz}ϒʰ+:ǵ51۵12[t?kˏ瑕xϏ @L7K kU8X=r;*D5BqOJ޲1;+kI0wW#:<H)R^@- /_?[y6l^fC#vgw9qsÂyٛ)$ך4kZɃw?fלA"4z[GKқ*5h08m[kEZJ"|W#L$hJ4ݎ w M]9VMPuiE?Cv~L}-w+xԖnL1\\o^7WyNlo%lc؏#wHfk^%S235ꈢŢ`jR>;? ae_Omof{^f% *.3 g4SL:)_~Bd.;Ԗ۪h/i0թKy J@z 2<}3sйbUȢS` ~M}A|g@brwTw?rKUqCQ9KA#ڶfS]wŦ'KdA,X TM}NkJVkѲ|oc+sB{y&n&vRh";etIczC8g[i9Az22ﻳ6~g%ޭ%ĉGښb/sc5U-MuӏgD..0҈#^UK=%]N\43Eg?\8gS9i]%% k\f_d_7/!#6v~U~e~U9NƜ;fXSutE_LP=n.\lDB!7,Hϰ+\吇=僯 GyL#nM(/$_?ɗ=ΞCEcmF0QWd&Tg j'ig\B?93ғvф 4䙤ٮ*j]"6_YG<щ8.FmHIr_{`&ހa㙪_.8&{2<+>xMGwxD+xѝHΞ." g!5|D̈ٝ U&3mJ"R lv_%j=W~稤Ӕ>{Kyn>2t49_1$(4湳k_%#!IU_z&CO?m`'A6aKZggʯ?W{rJ7e-$Z3a>t #BO\St&(  k8)oĜRE#w<~u;~k>mP@cг+cxR`hjս뤆}9O]hE (6&eMh>gl4vQ .ccP_~ll + eFթsjb3^ڌ[TnAQZզ8: 9tNu<ڊFП71=tPG (T2R&67RSNӇz:7{PI2| ɚģbcS6EliD8u>,{Rf-/P5)+ITil/ѕ?#crzl~2Gʝ#w;~ތVK]k=}\uߏģ`ibfSK~Yn~Ue8FD''us3@$4[xZfl^ũ=fLH24s^rw,ue'| F$KiRXD_&G?9e^[TJG&"S1%5ؗf}E;xi'Ш]p['PZM6+@pCAWouBDjNAd*,:q"܂+>ů{T~_K{fSa*򅟬R}, j^4.*b MbB+UB@ZCEDݺ P4jX.k"r24b᳀g=8{+_, |>eU7ˊzm>5CEb)+H.!PMdN-]Ŧ3W/WʄDž?DZ2!!R2@Bb2VvdZ)z |-h `d hrа "?Mh:BEޅ'2`05ZhK {>u$?XXrP+V5qsbI=܉rr{-BM*6 Zb.O0Sdvj(MЦC9,|幉 LעBqbS6K,zcRF`Xj|Thpeh0[G_\apm?h9m9ޑnVD1܇]9[d؋&"m/KR]A\z3|l ̥OI8qtĆ*(RTܿVr,FҦWDEUb՜`+`>Y\z=V 3+7Ss: EK"~1R ?D>01NA@!o.8f9V\BZ"}+6T+-Yys .)(=i%yZ}z6?RghStfe ơ\iv0dm+=fpr耀"O( 2iUOd&ۮL]v*%q~8FPK~:HIڔ"**>ܤJEuc^y!O=\npI_6!_$"j4G/[Ul1Y5XPGڼ芏665yZ_jȨoNs>,>GQ2id>iSx촬l.C/kqBGyuP7S  uN6̿iYaOHp ]qe=&$`L_" xS^"OgEdyShL]%d, "Ϝ-94(.F!16Z mL > stream xViTY~ERR0 TT@N(6⮈l D qlׇ"p\*((*0nGEO2:ݧnV|qμ ݿGzuAJ;0LQQƸE^rfvR&-&V: F9ώ=; % q޷_ KMq1Ft MRbuntoXhpY.,"1E'/&R#1qKS"7- 65>!|^(MF.h rEn( MEhfB( D4!/䍂$4i#mRQ(]et*bkWpWD*(~VWTֱ.jn# U?OF R[4(M03#Ԑ>,xrd%%wv:8 ${X,y}٩t0t5 ZAo4wUhrpD-yBw&4)R~WESW24 t N Ǎ0ğ!|-  ?Qb6a;=G7s-EZT^a*m2*쟃yt$}HYF+7.stO>!}whl`H@ /Qa-l;ܑC3ᷗݎ53Ō?g'ƅ; <}vߜ7o4ߔQcpd.Rw:1Fi͇^b0/C[f^G%_o}#ǜU^IWHth:B/M&h-8#G/ +rj+uT|RjjuzOS#)suF`RM!-ĕ14(b S廳ί]332~񢴠hö6=oMޚ4BNlo-7bOs]gn2٦)jK:PZlel@NG-L^3?,)bQ{tt<_xX,2('g~DѨhқ i$ \7|X+'ƏU(p%:B =[Yڗ~ܘ謼PLQTAY J#ޒ@RRD%=ht(-C`+cUJj䕷r堿ژa%/`~܄@YhRzC F_ n`☥g.Bɞ7Řӳdevљ§b=JZ l؜Yws2 ȹ~sU(6_Vl۴k{W!WX:iG:bxg@ Rxr0z ڴeh}(ٷ%!٢b6fi R/ӁhԷhSu$/+%Ȱc&&TKv˫75-7r??Ag#A\c1/.e@$Ș=ڽltH$ZnłE3p$^;{77=rW^9#VK[+A/FI,&  Sr=!=~xGC-#zb>t>d0!D=5xנ~B4PsM%C&% ۓn"%K%թWĎ;BLt:MU.S J268<>n2D/s3. u2)P **m*"&6.&{?g,ډu;<+U]ƿKiuG+VV샕4I{]adc +]y5MLD<]?Βq+4#8PSE!#=%~E؋S M{€'w=5ݵZz䒁$zDLS )WsHb]Q|/"lնd)_?xohi6WPd8v+ 6tYS~/sSWX@KƣKN0'%,Btnځ~0L7ԟZX;<#aGk5js$tRއǃ3R#=ɞ`90W>8r及zXq[ףuz7q'}^ %{]=odJ"URK|א.*7EM6 k6lNm,*ra|th =y ;Cr$Wendstream endobj 453 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3922 >> stream xWy\Wמ1df J$l.PveU((E֭^ԯV (n"(ڢ@bmTjLzï ;{ys Mh6 HJNJM_ V`=Nm抅2!cbqfD8a q(M[.2bYflLMNɒvϕ'ikjr|d'elV$g*o*_KQ`q}|3gl ʉ_}܄Đ a)+VnJRr>g||GeCRT5 S3[JʎfRQ=EC-hj)H|('ʗr(ʟMPDSsT05 S)3JBMxʜhj2eIMJ)SjI TBs׸qq"'1QPL q˄15;b\87Vq l(7,7l2h'Fˌs`$.>(bSb0JI3-OF! \\#LowS@*ᮊѠ9g`9A 9 @e<ⅻiq~O UFˠTބ|E;0* U+?T,$߶œlhvJ\.ioZIž&j6cx/r.DaL}c]"!H0',\nq%&(dۿ/F,Wo\tT{O|Xɹ1pJsU2ϓ_BuW϶ܯH_y@j=}*(Uդ`Yrq@i:h_@ᨔ>e6Þ-͊[p8 bGi v.`B0kL3ͧ}wOƿ![7T|e_UމG3eɹ†;r?^ȖX9 ^C&'gn/gsx(cw^fVjwW#.(\ícʎsz> 0 C`|=f8A؁(JS,!,pxJ!~ 17 #.RC+3ƲlKA9 3p~U$d5:=pJ;Th2-sSHU\o!7?Y ?:JQS_9yW _KZg9Л)O[^jl`!9ĮvtT6ɟ.q+aXzDݮEB9 ցZ6ؘpF@$_βQ]HVh5 U̅_^<|?)mehwE2W_6]L3ِ+*8ఈt<2QM ՗N֢L]ЁIM Vp5Qk\m0QO1/  `Gx [h%n/t+ZV%[y}jʪqY,O\e볡n\S`P+N4#0rA$ o %}Nt;0QogDCc$j=p=MQٙ;Ғܣh7foM_lzsDk4"T&̖Bq=q1Rx{_ס^̼Z "$7 gGgw>&IM sTQ6;[FB0gː4M~O[M !؎qQ bGWJ?m IR<"1P)LeDޘZ_8/ٲv95g,s&2xn/Ix.N%C[BI,20Ox us?wWrHed>*6]5 )׍yp{a.o{sO><q^Ok;x}쬙N1a ~:FeEpT^wLMgӰ(g]DAHcH$uo0G|U5q/?DU @QI}Lu+)Wi{o^,svsƮBXfloB [d]swY>2&nmM&Nn5L9~Y^ ۾ILAӟR^.wrd[wn(d?7<8wM<^l ֈXL2DZ<@ h^7ҙ36"iSY1IfmcZ7 +3lb Vp nBIAq>݈Dؤ겪i€ x,g?ߕ[d t]Mܗ#ݓk#;w2>&cT i {~. sO3RRC4 B2,X 5ƽn د8ATr0)x3 QarwBedsPȷ_[:n55mmjeN<9MMG=AW A3Qx/P U]iAF`$#Ħs.+X-a[58` ]o`Wsr vuOMTdF A |]GW"X񊷵}/vl놣IJqlcCQAc㞣)?Ujendstream endobj 454 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /Filter /DCTDecode /Height 75 /Subtype /Image /Width 75 /Length 1277 >> stream AdobedC    %,'..+'+*17F;14B4*+=S>BHJNON/;V\UL[FMNKC $$K2+2KKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKK" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?Ŵ݈?7cV):ku?7c^ܣqF[+2º竡t.!Vj R-QEG@z WzrSNjSUFA'Bjk!Vj R-QEF3P^ylVMbE7dO̿/%?Gy/FsG'^ں|OA\p$a_*ՏV-JtlqݝQX?2[i9_E85e=0G*I!?uڈMoX2|y"o@\W !۷+{%ݍⵢҹW3_jiJVi[%*w~~!&٥EfkG0՟bN)O<էUFEZnnPCVdQrҲEkEk,s\.~cۿuZv5Ϸ?i`z~mwl(u]7d9ܐOs:Svendstream endobj 455 0 obj << /Filter /FlateDecode /Length 5260 >> stream x\K6cOlԑ'AO`{ c1!VZd$Y73 XV+tPU#2Diji_^z!M~ŷ\ ]Ӊի gjMkںSfsx^r+mS7Ff{ߜpURnU=fm#{w|/տWM~%]==wI'~J8w~6'OJt`%Ս:dbT&JZEm\\j-6 dd-awL?0ק/8.vlӘF5vJY7 [ҋS ø{][˲i3/yu"pwRm2NVntՋ %8H:Xke԰Jp؂PU=M]?%~8wAwTRw< Ju~%.ҏ(pĮsxl`Zvl cKzf|i_Y8~^:k|z9دՠ_K6Vt]M bL'JiM;؏)X܄'m)]kmqu=&~J?lux 2r> 40,̕-/NJWN'?kǵ{)LI:LB| <2=0?n5 o#{kFaZVLr$7E1»^̤n`¥m.a~Ie {d զ30>*٢)& S (ΒZ2 y\aKfKwgAiVIta]U5tPl+f˽dL|7aULKeeڎZVXǼn[ HoK])"m֥]>l/ S9MNOwE`V{fb{Xb0{ X^%iU 3m3`9WL9sӰ03+`0z  ʅ#fajh@9MvX8Й6C|njRwZ g!!\wH. zI{~Ϟ2G 7yCE6fҒGIӵF\lߨ`d hܬL hӠ*؏/-R^Ҫ0r~<'8| x(OKJcDLSU?6MN2'uɣ#9ePٴʂ3`0̠HQNn/"Lz]~㴏50nA]KuL ,&>Eh'+PL;f;|;'[1pG2&oB+)"|d u&J,ٰc|(h?q~&'ʘs}ʂrub\C}5KH`h,pӴla&($ȼ㥁Krg) i{Hfme@LV٠EAb?բ;vT|8>Mᖸ8`QVOt@0>2\gͫ9lتUt%06~|s\Ӄ$ K-}xiX0C"“3co&4̐a"`,7ĊyB JN^R0)k=qN埠 N0溨 <ݿ BykvOC߉Ù];dW#ܟe cVGiVz9O/a)Ngַ I 2M%pZ=_7tRX:(;K ?2)'Ocq.s08|;7zϢzxƦ}C7=~Am|$ h,L{׏Q_Q*5CBZ͵|+t!:xⰐ/y7]ښvV t7_`)ZZ=0%EC2|L }iq3&xD"i܆ϋͤv FX]`+QZ=4Ne28$WHƬ)* Fa$6A3I YnPIXi#ԙ |4GVf4t5,[3ܴA4%g'3XGϕDDBS5ْCQ9oZ@3N)8ČiVyQu.8P3!u[+ĹjaÖl܇7.;ǃ!Ir]mƕHEi _]C)X,_d,%hֹ (g5꬇Np Pm;z^.-y&  θܿY~a6f=j, =_{\S;-7 Mh}_Xp]J.%3 HJUG:C qL?GZZJg>f؈nGbSqep{ˁK?2f.‘ IT[t M9t9 J? ø,r=VtO"نĩ/qkTw&:s*|5Do`çaϻR= өy 丹XXG0QVy8"u&V= [0(NJh;oYϗOYyz 4'Q6jCSj͚>L*R68peŹ0)юy=ń ϸ+Bḝo 3àSBW*'UH7~95R5U]Jt/- _j2|15t[#W X εѲ~eӈG@%"W @ChB"M^L0DTkYNܼ]K\C螌~vd.jiY%b ~?̙[k2?cXԙ?1| |ôNk*T!+8\6҇Ta־(Sqr^`\iXNv, -݋!WCPaM&O5`pvzZ8Vೄ fM?0+˔ UT+ nfePMۍִYMLo!yOE _l,R!2P5n_DVLh"v4|eGK: cg"L[Pv;ʉ#CM+- \>%|[.(HӐtA# b30+644](@uhBeL`nY<aV|b'+D#kAfݍqnEQD/"փr~f ᖙ߯*5V5+hz:J\6P} ilr0g=_RYcE/ S3]^}i9|3CL5b}v+_6t+?M=ŕ4x~O^KLҾbE)=+r }.>X1ň`Ho8\LcOpAh~.qY8p+\Jߣ@Z;8 ϶ݛ\Sʗkkr;^Ix%{լ{Fu/l.ŔnV 7(r%zx)zKicyȃl&T;ݏ]+ e3Z$ϨvF\VG*bFG:֖RFw?;"5?K_|OW]MUP$DB u ]Xv1yU.!#"poע6k$:T;o0NϹ%ԭ e: f7Gݘ+T$OŐN9M)gZY+,Z'X屘lBG Y̗e/;h.t *Ӛ+7)C&VtEdE3|dD MScY;rҝƫEb]*]8y7'n /;bnvJqzqfg -[ܲ`xoJZޚ|oabxAo&0uL~害:*忔}9´Ƶ%MCQm /\̟JQFImVK="u$,XN{"Td(l5Wxú߭'ރ~_Z= m"Ο$m8endstream endobj 456 0 obj << /Filter /FlateDecode /Length 4751 >> stream x\K8r?ذQGCś#|zvǡQؠTuIj3 `K1&A03/ kW x&?:o,tkԛEvNVxMwkۜNYlwRֹg,;\ql5x?`xdU~o.ה^Ԡ5Ne DoRVsv3))m[*c]s? xJ?G7 t9ɍ_l}xXՇ4JJ<ٌ'[I͏^YZvanv7~" ד.' 2eT7uoR:Zhtg2s]3l9rM>\Tb!cDD-s .:Ao3>-I۬V +p]3?J=nŧ!#SR5w jÖa{ -˧(C緳t~3VztudTzD08nK":FѲh2x$)Gn`K-o3ω;C4s c?:vPUt:: p&L1г͛.P3%6:>8c]3 Hy# 7;S=?e DT^x@8* n(ͤYۭyJ}`tuO5M>{13Q;3J 37~ٝ=8ƚ1́5ۀd-QF' [6u3y~>=Fd;XqOD^%{%^ 3$_9g~;5>QrSϢ+)^%xr O]UӰa_)BxCx7Zpz>L(e8#eA7LZ}\ȱ !9OqƇcPfKᆖ=ԍX>f,+7,DŽI\v*u ˝3\r‚CXziA/'e~_w:'u\Ȥ,\KjO La״oRU :@b & ϋ [ө31L3bVv/t EZt~uJ+#QH\N]>Y~Ȥ쪕?$7}}jGa\-TDsxxDW ( Q~YP+,L b3z*cnJ*.2Ԣ 7-e#Ȓ3S26u[B6aQ.+ ? SB#y̰oJ`}֍o~(h] Lq>T|%zBݡ왖z%2:e9}|YJQiAars _ y=8Eթ@ aw}nRSHð!T]O=U(KG"1 V7n%p}i^B޿; oqކb|)PoI#YHpJU㧒^G<yKpKPx--)"`f\<$tdސNDy94cSekQvu$A}ꩣViF|A \X? /킰|e),BaނFo~ܾv͋i VU^&Z3Mn-eSD<K2YYFȬiew@`yUqY5XiP+)|/pˣ\+/]:Rr¶ٗY.LY7H{%5kIflY&;_^r?)q[Kt\70]d,Mpw3K>BP֒z_nmW8rZyѷe l>Lla ) ҺbmNq B""! F[I ЫyGhtwur[rV9̒]!Zqc+%J2wHp֫p˳ڴ64 ,D4p^&s_=Oл5Ox.WJ~mF\Z?bsJt^7[űC?JV2h GgMY#Zl4Wic x;\u_YۈPE?/צ5B?/L GJ6W8A胇dd +*^wRB N*@B,r(LsyR L[Xd#_{ܤ\|6AP]U2F%%CEqzD,h5Sa?5Q!,fKxO5+2?XgëIVA:z0W3.Cq`6J+rx=J^k zEWᨬ,f1:iNx+DS(Uxr7Շ[57?F+?SNfOeR]eAJ9T$KȁҬYR=>™ZbG'2yDy(9 ry_d\0Gc +nw8MЛrp=ӗcCe`?P!hW.4&>W'Z&0C3T$Ǩ/ek 5W [7endstream endobj 457 0 obj << /Filter /FlateDecode /Length 3593 >> stream xZ[o~_H y 2+EQ A"E">XAJKLIʒ {.3 /^̜|6O\y8)NoNޟwy8,~WE%NߜqiiʼRp ;] .e W'^E^'u04;TڹfWJUU)*K8H啳O"gwJvv?mq}lLeX; R*Zh\4CԸtyʆt7eSaz? ; Wؼ(TM[i#9^fOBg-CA= YU [hG &] gYf]S6) UаFr3]/Jki:xY%)4:hnj7Tf^9>Le]*6Bv0?9+?!A06sX+[L*p7S'+Σٕ[RJfGHYe~^a8ů `LB?3YzJa&JB,Qb=GA"-㸥+/V޸(*1}&7s}*is Ifrȝт60қ>bw|`)m{U^;# X  G33Q. >Z 0fBUuBϤr]D%Bl2Fc5*o:^*>7`+FQ;2:-P/ӵ+!pl]ÖQ!g1=Jߗ{7C:'_hnsE_w/N.13r#2i;&'_";8C|13N1$D L92WPBfL) rݢBQ>ԇCڭy Q@<+;ͷ;Wur/%ĢgYbH;#a۱a\("gaeڙ9m4%MZJz@ϛ3lˑDwzNJS&`1"0il , [fPe?] 7|r(1e^G? q~ Mzÿ-W`oeߦB'eEG=5d `PP5ɵ0KkkܭN<Jl{w,}sh8JT!.]ݵqjXM QɊ*dqֳ7`Ot~j}g- YR|59it^ҕkr=dgc(`GqN7 aƼ|d?+B͸aGj\3/u1K$H'd,rN)IHQ( `90e<@PI`o $wmQmTtJkVv[&Ch6E,P|pY Ƣ糙V9ficfQP33z~xa-7y⑹g֊X/Spvp}vO׷hp$:wwmsIw뭶TZ"*LkYT)(,%^Z0!M?Zkj: C)V&ͮ|ɸDм") ! :=WkEh+u x% @<߬bn?pHNmfFlc,7N ;ᰤ:FKZ錙@kH! ]>6T$D.CM.m~ "ulzEk 8AkCWeE~2bf2p5;Q`zV?y/XMBnV~䯘*̸5 11}XF_ͳI-X#'@W/4~t%US aMutoÑOk-Uc@YU@>f!s XBʢ/$U`$.h "AyobzӀYLQC-1²%,/'QGZk2+`eޅ,h؟B>F:<wnOaI 6ĸ%NG%3L3%zjn{"c,K*gawmS3a g;'39q| ⸑t)_eg2Rլ1O>ʔOBOv0TKM`j*3׹ kzӇk hC zB{ D.+vto͢-ɴsbH Ûpчx 2Z~覧q8/&pNYvñw6XWt7+E;\qc 5%9&kuȘmcE#@qwe#]о%ERz=KejVzI)_r+n8"6/5!L0يwGo%muZV̺m iDp$k^EnjeYhۢ?Vqo?ZfZ`h.;2OR1oZ]`4կ<ڧ0Nso(v)43]ڬp ]j[d`MSΞ_L8y%Go~5Z}3 SyUJb:CTzD]JɛCw|af _x62O)[p [!U$ADϟљ!k]=]d_LѤ+ @R g#'n[}- bW{sYjcW=Փ.io/p=^k3Zd='kT-0pXNZak} 8S}~&ҪZEh.gf{zMBa=7T,ShӚ [Q؏1 HYx`禧\xnc;x~u~]\K)[;h|`gN5X7VCʹONendstream endobj 458 0 obj << /Filter /FlateDecode /Length 2972 >> stream xZ[s6~_Ktfwv8];[<8c1蒴spNB8W|YYtvw53zv<ǥTˁ%3DI!r}pM.94IE&iIQ,˒4Ynpj`:c$m')%~0Bs=3&gM VO99 ŵUWj&'Wk ,a*I9I_] >'Y'TgB|_C7-8E^swMޝ/d'z4O$KDJw0g&T`A)T鄦r#?UwK(QW˃b`l c`)`XD?͏,w-; )Bk}EI>Q7&_BLXXr[qTQ꾉P6j Ίϐie|-h-hqa Jjq|Ո|ԠNZhbMS/;9#= }8 D$RJǗ7cBCP +|;BWIzI5"bA`*h 4#G$s)':Qkب〤o\A߼8ӘgίZWl)uHy ƌAE.E T, 8hY)hKpd伀sQ;R:8ĨC/OQS@ԚDHozu\_@m(M b4+n:|\:Z;LcURoXoϔ|W:5rAWn?ݰq. #v"aXUlz !6s͏j#Z1,;D>\"dQ u1{"2!E.QQfGA)E5 R]S5mH*&ĭQn[] g(a7`3(#;5>LﭝxmtTgW;ӑvb׶]~Bߦ XuG%dr 0|M<|dT/#pp \O1J z&#,:O[3fKQih2A轌jsevbUjAjS" HH")Ӊ4N$6'J"\ZwCJlMsGkN0hT(7-]8ֽtSJtMhHdf@j.>v/-\[-Km^y*T04uЍ~Oz(%<|ȩQ RBS}H2)&. ;Ɂ$K k M "T ӱn'XW6PV*lrV6{Fr : ;jC -.㢎^jqDjJʂ>q3^an(EP,m V;cFmAg]1y̻l(iuR,ٓge@xk!h8]4.+C 7R|YFbT Ol/Ԃ-JS =jżM$CE]Gư4&TC Lr{W` Y]:XXoC,zc2v~vQ!ޟnE&-x,L nK[\'|q4C|WmaTƥ]3炄υjSK*:`w5Àd5K2n;n Q0~& |W"ؗmn ?a>l",\g6ڬmYIm{TGI. ^y]vju)o`Pm+{ VGZ}s442vjendstream endobj 459 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2280 >> stream xmVyPwff[PgM"FnY͢(x 0 dFa 0oCC%0eܘDJRkJz٤6s&Uu{5M)=(2k\;yUzCFjl;DK=?)lz4Q <|oq<>i,鵩9 M[sҒ IfKfWq93a)dm1A63|v)K>LN7qD)QZN*RdՊfݞ:(Jm4mMK7gd'# IɑSS *ZIER(j Z@-Bl-oT5KSjʛ򗑠{DxP] uU'y~ýΙ35"D.222iq1eD ŭ0 ұ+!AC..ֱ@_JVըL<\"arǡ򖬅.w҇WBJA'%ŗT̽yc_t6/9/!lD!NVwi=mNa FINS\7F֢_?Vjt5N9QF4& ,?LB]4A3Ԗ4Y! eM !~Dv͆ԎwldyζmǃθtנKNpyGHHJ7Ŧ!ؾf2w‡എ9󵽨 ۍq]Y]-.AoF:_]tՇW*p5jڹ~K2JWU+[K3K{niq3pUouN~a{JInۥJ?ە? ¹FB#t(4kfRkT;\Wȧ57EKBN#|DF'W>bv$R]%/ԱMy3|AP_d^ɠBbEݹ-P64doF /]fV=2;cp{I`_5|}TJIjM+1 bJw9[yf()!/Cu^d(*EV[۠' !I=M[L';V/!МWjP-l!%czvv27RVU.ph ,yJ6d{)׆{k(\4$ ܰ c=0-St\gp4SH!8Jg'v YKEwkK |0s\7B"Z2}59NT><:q.ȀE+c?|xF9ҁ#cFGE_Ú8VY DStP" #l]^Ww[?t3 N u<:0l(^RHH_23^wA~GzvobN8]fNP t@V} S̲=C_ՏD_ɋ008?v~+@`[=w;cD40AWps!x !x^|FPɉ34'4#O@%m5X__f "^on0kR㭉 })Qڼj†PeI&ᄕ̶mZ]xޙs!?ٙ=yڲ=e6kIqir5Țu|bxZϿq._ƒ/u–uSO<{gۣ5nKg:߭O- kl7lxB~?C8wgo6låi,,p+{;T|eIͺ}|la@uu(w~KR1ƨa0D n1U&WYʒ덽!> stream xcd`ab`dd N+64 JM/I, f!Cß^=<<<,*=3#cxzs~AeQfzF.THTpSJL//THKQS/ f*h)$f$))F(+k꡻ g``` b`0f`bdd ?SUe/>0oaWw[V}GoG~zw#/ KUؾs p+]#`-ýyVT#3z@| НVendstream endobj 461 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 283 >> stream xcd`ab`dd M34 JM/I,f!Cܬ<<,7 }_1<9(3=DXWHZ*$U*8)x%&ggg*$(x)34R3sBR#B]܃C50\``````(a`bdd?3qG߷0~բxy؜u̙[r| 87mBU\XBBy8yL;ódKމ}}}&201g>endstream endobj 462 0 obj << /Filter /FlateDecode /Length 215 >> stream x]1nC! @wN >8)iKdhUL>"?Co_lt<%zzkKU\broL\sXLpUM_?*@i{#),nj\HCJO0? jq`+DVEmY# ]箛ΡK9 < ]7#n̪ý5*lH6BKK,Qhqm4endstream endobj 463 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1031 >> stream xmL[eǟb{)'Y Uho5 ,[$E16AV^/@RG޾Ж{K1Y7˺-&M?,/?,υQods>?9y(T@EU0O um}N<^=)=FI5 V $ٺ}JЖ}VS+CہTmVǨ{|xphijllsLyi38\Αal?5t40.8<3}!uq 0-=̑]Ky0x_b, 鴌Me6?*T#:Gͻԯw0Μt9g> R9㢰[t |0$hއkaa'D9:_VMX͝9utX<A}0W6v513:z0H ax5-5ھ:Ѹe\69#((q36[YXv`cEXn3$6p<=Ccy 8}x==4e҃Q0D=J6e<g\e+2:9_%ϗO-9iV~ӗ>U`-\4oQ] RI8فE%CddѹDqGӘb,;B( P,q aNOdZ ZLˀ2y猡XPy\CmlT>=sb_<^?&B~&E!`| ]/&Q#c KPa(wזb5HGy!gh4e,o<}hf6endstream endobj 464 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1907 >> stream xU TeٙW#Y񕙍>!6 Z (3ASX`W`y.²CaF*FϘh5Ěj%VZ[IӞs;w}GFP2,dXCv>2<6uc~Vbq4F& ^nQRcP%%bS2ꍆyM܌F4vzx8y$4QLCa^f&QX1 $^1iShV͏,}{ y^EQ/2S荟NZEMEQkh* B)FPDSJNRTL-4 2`@# t+{OxyQ;P :!]!2K,ţ|Nq˳pӪ[VZUuz ,tqhp >/^]̨N 'x[a%Pe>a"k7ZTߪf3I%i]áᔓȹL;-Jv;gs)3,fmm~zcU7sh#lN=>7<^ԫV:#'y_NOLIePi1~AQloo Sl*`9d [PZa9Fkw??V0_Tc2R5%ͮc:i,nuΛwGޞ\oJ([yvOe%pOlx;G}$E? S@L6^U  #9B-| 6V+=R9Mz}Qoik|P$nfnMfLͭXzR}1g[ B‚M/N\R&w/}λ\2jxj뙍C!!lU9 VbaBO~VtzKGׅpVZ -0  X}8Ӛ YZw<́~&^.!r)nL;xR%%ʛD8Ϫ4e ;/W Fx(X` L"堅,VuXFcа:13 g +©c,uG= üJwj-X}zQq0PkJPVu'{wUqh4"@J9N7S(Fw)M`@=9nG! =A2/_ZS(Cc~OJ՞RB_:y1),L㡹i}M;fzr1?qmh2\e?tg\]b]);oMl<p.SGw # ȉɄ?ˠV4Kt9_UvV "CuU-As/ӱR-NܩJQUrendstream endobj 465 0 obj << /Filter /FlateDecode /Length 222 >> stream x]=n0 FwB70 .ɒ!ED, 3%CG"A}|:FMFّ~cc˴W/~T|~߁kS#=|pH Wkǘ^WfPjǟNթPa=zTX (SNv2ETX(JU~/(O0oED$\/:W鲌rsendstream endobj 466 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1733 >> stream x}LK&]7wXkܤn7MViK%5$`6`ow|v]xKX"5˲vU4ں?&hH٤II?{y{>W!rE U[_Rq k"Qk_/+>8Ĩw2DAu鐶Ǥhk7Ⱦݻ?5dʔ͝}gLikbIF֤jWvʴ*UÊ'߳)"]ҡ>@*Hr>"GʑG1)Fn E,jD`;>+r",gׄ,ĜNV٢e2+xr~?E]={huJV.@ .} {#/0WSo,:m@g뫔X]EFFcE7z(OȎ29Gok`MyӃ5@|AyWë'8W\tvfZ`z`HB:a{;9f+Nndb? >Yu >o~/ ~GW()bfk8aŻ3`T˂EAAI΍Y-45B8}~* zvoA>1 &5+r;՞,}ù'w߮xՕs)2zn6:PN.9yS\d| ?ՅKJ{u{ܽHG#3Aʦr_YY/z5.}*Áf@D8EOOħaTz՚vwHe?44hVG7sE {K=ΠmɃ`f쇟K|xkJ[^m1iMf'1%wKBH U>&l:⣒a,wgecqJR^[H3Xo:(:a5=:jNw-h6T g?`Hc% ;‡"/~TJz'QgGCM{̷}M ; J C*bp7H;`N"!$ ;)ohTK>?oDO܍W%B#PPſ$?'M;&/f}Ǹ=>E TMxn|f&NX7 O/gOVV7(XB7hv}.._%0nWg^ x$ȅD(Vݷ7 ȷ^XL)~o>TD=hƜ;SPn:z.[?k!]Xh3Hйs}ni[*> stream xUkL[uӞ HkSl.L a"i$U.ҕ0ƥnJĴ}Bmn\d .fL4D&jF$|yOc&~y/oCia7+k= ͞V9ӤgYuT,_e)\c/.BmRKH d 0GZ%Jbۺ͢"Gtj~zj1_Ece؝D\3\9p61&^Qޮ0 ? Ztt76(Wp45-P2t:0 5`_sעIX0h|{ ОGFb(Gf:|1{k L,# a=U]t/jiqlGJ]p؀{12Ѽ(3Xh x+b.Vf*H~X'NĝR>#ȱӊ.U]Y{v4w>j;KД{qnDUUZB\_KMP?/k0o1[$,sK2 Z;=[Eu {,@\?x,7H-Jmܜ'$~F)ǿD< ׏X[l/X5$Xe::kJ6NLÁˁO.M_cychFz3&jU <46tXzt_Bc'nCnqGOEpd8<::V Dtl8$~oQendstream endobj 468 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 449 >> stream xcd`ab`ddM,M) JM/I,If!CgɏTnn? ~-[_PYQ`d`` $-*ˋ3R|ˁ y I9i i ! A Az݆*X\ZY c```b`f`XȢVi w2,'Ve3\f{<&a' EOlzZ3&vϓع$CƬڽs:wKVvr4[iݔvh}uMŌ֩U|~x7׵vWHk{{˔˺vΩ-zieonɹgϒkyO-.býw䞉=z,3wZ^ɶendstream endobj 469 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 568 >> stream xcd`ab`dd M̳uIf!CwO<<,L ݛ3#cxJs~AeQfzF.THTpSJL//THKQS/ f*h)$f$))F(+k8 a```* f`b0a`:Lm uЖW|!.w~v? dܭ[򷹪ot=}p}7vo^}7ݕ% aY' |0}@WL`Cgw]?|ǏqߙJyVW\g |*zږts,뙴X]]%%r9kX]i몤03qmSۛI<\ϑSk[$iҺ`9M'Vwͮnn.^]pzOϢEr+W\}޲[\ojg=~ԙlqqpvpo> stream x\K۸_H qdk+MUI`虱̵4RgH5I0H~~454=\5W~?7W5K6-ܼrK؆YU[n2u+p]uS7JִUwoYmVQ7NxW  ^%kWX VZ}9;ѦWᒮ75j?EWIdk$֍dx'B)UOWT3hZ @b3oyқ?ݚG1XQl`{ƅ÷.>pGdJ)?|$aV}w:yY]vCw,kw>a1fL^:CHc"DN~k]8xkHִ'5Anz]Hz>wQGuIoxQ6QVՍjiTCQURhM-lFq%8FcȩFCSvנ2 G *Fڛ~pXfc6n.j&s-[+|Ԭ:\{!;泷#Y,=htbUĜ#p1ndg).ܲ^.܂K>ۘm9t#֖tjtpZ`),>@ &PxJt'Pv ;vI8ߓ˛~W* vjF81[ݒ8 /7O%cE@UxY>D qw$HTEgUV/-N3|`;izxpC\bO,xD\Ntq7x nCu`]H?ĊAw=cbTuZNpBi Ą9Q~gtdsgFY=]؈̿2!=8i, ak-gl)4DtJ;|d$|>~ +A?mr]S&tװs›ڱ Dm˫UNRh{dy`ZHI&] bfVfշݢH|m)%#b081ݻ|.@9W-9-1N|p|0e+Y1II 7Dauaޒ!/'"Q,q6:Q4JLUS-9YR <6D$vGLY:6_~.9fCn度UeU^SF!%nYJZ9`X5 )PjAQO e|zR=UfXB265T- m %O+;6ֲtmLͥnԵ'1m&?U456ͤ°-(P,*%}32^/ТW:O`Jv @c[Ɋ'+h5a y(%yJb2{,eŋ$tDt Ig),ىZrȳp\lr3O|4TZRJqߥfTF\)6r8A#N~^Uo"AAF/rj([_~E}tRT$Ul,mjji|a#me`̜%ڢv,Fʾf\a<0CBir%.V55}|0y A'_V I~uWtfy*tfaZ[D wwT!j0j_=]ť㫕tЛ:x2S%C)qt܍ ~Q9 Jfdv)< \C?jWvH7nmfn4,Cer%r\vO&Oљ()3o^ V;4l*aGYra 3LP^lm%c<\MiT%N4Gd~lq` ܽ!izs}D8hڧBI\-9&?PAgI|U#~ Ԑ[fe+Àu*NhM偢1'ƌn[ؔ{.DfHk̩s:n:j*?A\&2}.eQnV喔52/ ~[lg2@3 |-`ڇWp* uL3CTh ZB9U}7SXlj4(7`Rk<S#ɩe&Ȟwߗ!huR-By DfT# i}U«8[F!i@@kU H ~) g3^%qUe5<>KDž1'Hhtpaz֗Ȕ2Kz}pwS(XY3yݑ?qSb,:O[ʉOvnqx5c O$h|uщZOXa\mK ?+}P*& GVf4z %Wp&|H4]ꄹyeZJ6tt:3MIۚ˗dޑ#AE 0\)IBb]Bg\nji{ZM r]M 6e,З9X1֠؍gBwqv8LX!@] v(w E*Qu:P*ӖJ=i^s)'PB Eyw8Y^$%: >Wxendstream endobj 471 0 obj << /Filter /FlateDecode /Length 270 >> stream x]An0E7` Nh6&VU {.xH_/״l/M%BYQ;b0؁LuB,V# `'hV!b ( 7" `MU]wakV#kͪ%gYu;}OId@g)V\+Xu̧T wendstream endobj 472 0 obj << /Filter /FlateDecode /Length1 22344 /Length 8791 >> stream x| |SU97mo4 Ji{Z(KڴJ[EEAm(;: >eQTV23cf]qwv2]twνiRs{;wB !Fiin"=_Lp*)SvG|$ J۲{O9!.IYl)]8PדzW[KwN6vPNY!"ToǎWe # #3J( ]s-$=@}t Ƚd Gs u~Dk=&"5>)I\Rq}"kM\Be>^i4.m6}d+ާ wWWvmd_YGNXGki.gM++-mA-OZA6\bZ#k.df`)|B""b%7Ko Ho8Nr*=&Joul&Q3PAzːT$I?p9-^y ;ş,j 0 a/f[trGW"D: N>ʅԅ+u}݅r}DH::b! P-\?#?3K> 04q3)%3d5t^ҏQSɕ$ g_DzN*ِOֈ]VFW}4$w6FvAPDAAĪ ڕM*$e+ij\T ᠧh<~2! hfwwqv{L_'(5U"3qJI-stYhX͊`XxGVuf!StTT uc A/_ *Uv.l v1Le'suWxq "(J(ڜruw˝^]kFkEX #DW>*ט:Zт=~9; DxXWo+,3BoĿ,X*.br#['2C)#0W51>ؐ@Jş2'e$eS$K,\RTښ뜋Miim^PUm/*s:h79(ui2֪8[ZmmrsҰc M5 k9٩46,hp"Rg3_jp1d 5sk\bMkUJPު,l#EM MuHűB % sV\Al:[[D֌"*Dc[6بip9[ iyCk^Tkw647)s(}NC Ei7,*z&NĉCf MV{Uikq4걡Q䐨{D#gqB@ x@W97 96U61Ե6#̞u>t~ށPl.`ވ8 Er\̷R#OZrՒp}WMܖ0eͶczy@ƝHK^̀Ja9ȒI?#)W7U,8JW7. 9$f qI_dzq4 mK%`TA?썄pv,G08'j=\}XUq`TƊ\e^q}TK3SZN$ 4 :HOn)3F(PMj%%V+?ZIJߨV`$k%4k%yH]p|ZI9ZINwH9&3U.z|rI.o<%*߸dh$%r%OzrU_ rEy+TaiI$a'H'n2UIDA(7LEzGH˱e'x)uWx | T Ru"Hk9 4ÅkZl-uH/Bűy HA,NAsq,(*׽qhuQprs8G{ ^R-z3r.̣ñDLL?>lu4~8kQ_ŸNHG)7.AZ'FFC> n䬗ct}g>(QLԸ:&X{=5[ $':(g ǬŃۯkuO.uLsAr^(Ģdzv@Л@?&#`b=Dl1 9mدs:GS΅<3m8>>GCdl,VK.s.<4mh{$ ]Nmßq*.]!:ZޢQg:q='us? h2zluwD?ݼ'J2{lȾQPwc4'2Ÿu 6:ux'u<Ϻx^㍍D=2/w\>./a?,{ bmqi18lLWY+z$v/Ϩvx#FJ FtܓN'\7R 힨*'h.цVtIb$V9ta}P!ї}n1m?d^%fo3SXN=F~\tIf9b#[\)Xǵ"h-ϰb06 ag߄Zi4 9k6ýG؊Y}֮' 5*'q8ա\5p1`g툻c[y}M:Z9v#Ay.g µq}ڹM\:dqp4Khi3zɵ(9uH+#gTs(fʬRR 6.#^ ߉#Nn;N=6r\͜Ǵ8q VbvcrJv%aKH!R99tс #?6pYkt]k85|1A5\Ff C);P)sRhŭߤ[7ƏSv<m6#u<~/xXg gCܩ WP rj9lԆ!{Nt0oݹx5XwZrmb%ez3 .>-i{V]'v ;v7^}h[{'Jz=>j`Uu`p2==1.[i8.tjQPqo!kTx;W&L^hpx(# &HC!]5ro:azY=} t2T`YkhgtU?u:ӧ? yy;G<R ΃Vg1S;AEΕΕp?a\I~Jok?s%ysD͹|\I&_\)_R<ކ+h=~U?% =]t9]O]%A?S&w$OaLwIS&;;e)2\<έm;wgG6ΎΎH>Q ?;~gGz4N|Oi䉏N|g;9dg&z~4ȜsUr~+8o^55cC47ϱȅdմh),ZVarZdXv)dy *XoQtYJτgELE# RQH]-Fmb *$`dɠ$dJP1{%jbzCoO>FIpGO"OU~=N "s\b>2Rd)-Dr4yG?R$>$lcdyf3 )!)9E)rjAM^ĬW^oח_ %VSVRKH%c~G꧇̟5r~[{e4x[r*Km)iƔtdLtkryJ\ZVnLK2C:=mq~])]vKMS)ٔbS'\:!e)YJ-崤ؐSHŜ,lNR=S&U刣"o_swͦϨW]AԿg_=r8K=\Y9Ԕ mQRB͓'OVYaL.۶0PE=yVD@S^M> O>coڱyBr cQuG44GMQ?;_KivvDKb1"HP$I>x׍u(Z2wfakjsi5E3t|zly)ŐDԟlO Fl05$I>yKWK*9xte\I5el挂7ܮ>Ug~Qcg 55 wяM;XB涯V83WE%ȟ%3l6&Fi^Z'؞?fN-K$Fz:Ad|P悎a L%e#42vFezwl\ye$r_0ț:O_RyÆ(Ã$@J6!/;#EL"!it R{ L"YiF,c-wlF ]CURZ Z[v<, 9ᗋƱc.ۼw._QtiGH +t 4ݬ֚ @2ӍzHcVi"B[0T[,%Gi!ǸFG..@%"m;;@r S^37(2v} &4R2 FS 5S*cQLvC2x+Rf@YPTYZPEW+WݨXtrwEO+OeWT Z .{ 6n+Zh^Y&hiBՓ*s3,E ]~_>G|C+~1ۅDi}8v=}K_7;.l./:#d6f2O >'sLaХ*m)-)))"Q7C++v|ӳ4JFL 1mo)saNfht񩙳s3!Anbs}V^uU/-ugOꓴ|hƇؗ%y4 s"ն(؟׼D1^-FcsŨ]=Cz*ek/L<xe/靷Ɣ{Hъyѻ~\B:f501}#yW+b~nr4!0sO{Ȟ*{&!HJSq:Q6ۃtÏܴSLw7=N͏2O= [ap 1G RtYDC&"?ck` D^˩iFSْ9ڏH]d9y)c_w%aFI"$wTy˄t6-$ \KoAS$& :sO|,zH;|B0]dK"򠴍l7I#3dt iDZ-82M%3+Wﱭ4}槤Pc꛶ĉI; 3_ȹendstream endobj 473 0 obj << /Filter /FlateDecode /Length 236 >> stream x]Mn! Fs n0?hțdE00L}ƸE G{/)(U|,LW>67Lj+ ~wj?q[4#[GŦ5G< %c{i7Q=(YG`  `UڳԫP3PݱZ@Xg@ׇ գF :>A),ZӮir1߇%sh^K}endstream endobj 474 0 obj << /Filter /FlateDecode /Length1 21880 /Length 8355 >> stream x| t[յ9+YG,?d;$E);$`Ym9HkhB <~  @xfhm!y- eYDŽcsǎ$|fHsg>n0B(mGuu!>_Tx+c yϟ⿃`~?:0GXxnܯ7oG`BpAX]١G8a^98ؤ¯rp͇<}[jgþ`?_F+# By4~YmI \<܏~;Ì/Ct!c/:wmb?)zwݺz鷰7ѝ耸G<&&\| 0:(Pػoof B)oxڇ(."0މv J[XGh pIJz c,Hu6]>FDŽ \\NuW|E y@rkڃþ[1e:zZa\X?#F3o]\[-}@qz `0v\_IV3FK t3nP%^Ǜzt?C;t#X'D)[ U}+V˯uNu,Z-JkI3}bU;z\g[jyߟxX}AHcdv1AEim,m,j,dXL:}hc36 -ɃlFE, 1F-X@E1AXXXi,((FPp6ήj(H1KTpi+*tnc$9Lȳsyrfyi(OĂWaA`< I[^P$< / bcSpȷrTPX r 2 0=p|id8 w eLWcP$,U_T0 dHxLȃD&ch`1)5ɳlS-|r`\D#D0 "#;XIUI4u'BCO6[^B9>9#z9? ]H(M˃Xh |a X 4zvʉ o`<KB)@&I=(3 `-qО1d_<|@"ё`8K0~C` # DA98c?B Xo4dヾaԴl@& _H,8rbs4B*S6C@?7׃ \rUu,@}1ktP  9j&>? I~S)1pGI셇7ˡ 7LXk L.c|H,8t0Ui/İ N"cM Bx*;`f6ʠ/!1uiȣpUʙS%!Y*$<IPeJyuΥәVj$MDu|u=Ғc'όi tBϥVjJTV+Q5`ϩVVZI>ZN ΢V3hF%8!Irj|N.o<% Gs.y-V2g_2ѩ%|6%d?KD/dlUuDӒKuDՑ|.ͬ䳪Ց|.sI*|) 3>|4$ nէ\l Մ lFk4v>jDEQ D $ȏwBFK& Vj0|eԝ ܃g g@ua(!hƇ|6M0}+(@DZH,aFNϦXQҩσJ.eyz'en hsL^T߀?{ 4{c\Հ#{3%uĞ1cmXfc?lA3ϢarstJ dWmQN M>ʣ:±$~a4Ei ,1࿪3i(PIn\>xOU4Z4QEF<$4͌L2&y(ס3:l<ښfd8vBgJAdYwHd^Tn)Np^h#QHFC?aM`2N~g?ǧ$O5%-iNƝ0FxfH 35pr&|B$d52\fMI:^٢Rg:<4O~K22luO|FS8^ m L:WUJޣnTLI.&A|Fgd:S1oN|_ٜyJor%dL==Z r)6r|cБ{ ϒ#Ԙirxd:AOih&Qg`jGU+tH^c{ҩ$~35Vi2mxOU>-cі$V9 jc2(p,̫h*~Ri1!Ӊ:`t̋VA͟š u\7c+p=\n.mx8%TD Z`ۑ3mJS2TkT`_oŠ x10) .롓SX>SםaF/f7yV$LL4Ej=GVTl6jVq~D{v̲WUSnR0;P-֮:K[Cn/F+x,z8ۺ'#<~kHyX:3d&( w&Cŕ=قMܟ5{RP!i皟$Ry{ɝY5̺әk3+5 pؑ)pUmI=:toɷcOVC;QfZSUIׁTe?MQw(LJEi\j]F>IoQ~ޫT6qBL|,[2m896H2]吩wT{ q zZCNԾak@S L)R{t&*NUI/DϨ4gu$!Ϭ:]~i}%}Rg_N:amW}1}%z~W|6t%\$j%&wn|1%zjw(/D]&:˔~"Lv/D?CIܺL`%`sj Ͽ_V;=e({G3N%3O;>,:>]9:>4s$NBNtجU zpjk&Wc߳!G{]&r  {V!QFC yC!U!Qȯ__)fo~o#?{Vg ً⫯^]|gI!EM! q򒉼]|Q!2N^Fy1B{)=gB~'ȏ[ȏ3 / ٯ>O)2B|JO* JpJבPO5c qw< GB* ˤ仮|8oM"{-䞻=2HvJ=Nߩ"wiEvt|;w$Ȯo=/Rȷn['}ymVI#[- 9@nZmnR? 7 8NnHJ74Y"]_G*}.Gi%0I&lW7rm>ٖK ٢ͅdS1X@88I|Fb 0DQHX!#&~,WȐ &4Na`8_kgB祀B}$Ŀ][U%#}.ѧk^\SMWuqL֚UpUnW*d UUdBV(īt+ tuVI]Ig鰐 iWHB.'d,s͞RB<{ISc4NKIK\ K]{q)dbI.'*4(~I#+dQYJ ] Y@8}Nعs'7/کAW޽j.]l4*AW+ԍ 75*_&]uu< ^䰢obC( D'FQ`j#ryaH:$YYٹG_y.B5`̃V&U^z)qtclxBF2rlq!v]9.ڋzq7kܰzbϳ= řUWοGrr-˫}{O|*8AdOSf6āGH-^cZ-η/mN9 ̖Rr۵H()mt<@1^'dI ' *HIj eAPDBdHdAuػ(X>SPn4X#k*bǚf,|WseWyg{}7#}>Վk[GM6~g_&\3JKER~A~TrsvVI4PQ**+e.UV̾@3 UReeE(?[hV>8(U{iQ69 heErO˭gb]W]zy=)zKi/˘ r8,Eg[, -&KlɱX,֚p) -ZSEIy#Iz d]Ej0KlE'V r^OxSXֶ%O}Mkz72[l{Q1ky^`lr@9LM:I h ƨD5aÃl%ZM:"8gW|l .&vf3X%].y Rۉk-N싸Ce'`25# 7k,ĉg 4?qp'=}7VCʕ ۵H Il6Q*a!`$TC(*l1K Ffj-T+&t>[Jee:4pꓙ:N> Te\Eyyw.yʷ׊eSx:}_,}W ̲pbvT 3^cU*/3 Apg :d4-9 ْdl0Pl»t֊;̂e*.P2 s*؜8 C,&soQ*DA,<|MW*;){V?ٲgײ%F?~m%*D+QsyZ _vkZí?.,+cJbnjP?Dt,55R~~>0OL+y #0[( 0"Ffٙ~&O?@LLZS~edFCDDIM- > stream x]=n0 FwB70.ɒAD" 31źC'Ys{/)(U1BY> stream x| |TwwfrɃWHr!2$1H2dB2N[#Hfƙ " @"eբbHk]dߺݮM-n7e;(>03|}w !d h﨩# ~1~RϏpp}u^Bxݽ*|-dLU['\=8SMƯ![/}gbOy!{ Ec/b9H_Fx?%D!r/d7g;pe/l%"wµ} y!_ 2W yCYE#\7_&p)Srq?|RJ7Il8&4 9M8;HeC;cd#Rf~#ĕSA|p{;}N ^GN?/ߌ:)< D|5iub%gf"t B5{}%g%UD3:?e;? troN}1i(πΈ2-S%B G M(5!!Ch#y"`DLL^qQt3ʎb1,B;A@+ ܲ2 z;jʙJʫWvG!O$o 1ʏ?ЋFA1rG@W1NŒC ` 0=^@ !3}QUhO1}>*$cNa4kB9C; tYC2hT1IU#4Ѓuj$}7$GCf9ߵ*?ԋF#Z/I.D 1 T/b $ *J8qJ]>MkF;MP"""qŖc> UL7`qo^&:H tj!n"q~c)Q` s@;# n)n.Qq">Z1X:RERÇ>狰C7*'ⰜҎoH4l˙2Zt0(~P F1]>ʎ@J{Q z]һrЫ1dUb̩^ΪP/jf6j$KJ0sw`D]9U)LXȢOZl\rG{kiپdk˭8/7+]2B8mr{lm[-/5e*!;e2G݆kMϵV2 Q A-9`oVf q"sN*;Nqy);;ņ8mىTll("jlwv[xȅf6ٖYK2"kG2F.l[Aw, vWi.T;-mlRs&&7PkCM Eilڗ&2k 'N$!-6j;F;N[AQmq$6FF ťx\NWY:"vdڳyr'5^/];lY[ae4X.۝_8F}[ n554N3Z5 1p56k #:jvK^:6n] $B4 , wu"1t)i$|'j37Rv7Kd5+;)sw$6e}Lp-sP _Ö㩇4fufwZ*5T63BAv>EJ!Xc4/p3% gq1֟< =Bc^y3ѳ^e|y[ObQAcXbl'?zH1I W~J1fQE v:΍Icօ1Ґ.CE9gXT 0aY'iJ!*Lqjk)%Drrְ "3j<VӭyS '<:Jz]R+?AMB_ E/4jb-Bx>&n?ǽZf[h{z.;7b ̐Aj.JjLD 4x$5RLf7\b9Tmw2 [Nl~Jlc79ݚDiY ݢR:3'2?$VTNN)6O f7b^6y^mtݫ*xu3Q}7Nc~V8&AFWA:7f^v.pl.%ayJo|%x=|Z1)T^v|W$(w0[-3]b"8޸0 oic9(408Eք9SEF9obL#JǖjCJPha٘ZtцĊv&kkOhH-{Ri>eeKi%?)jݘ4q1ʮqŢAY;1w%sr?7Gq+*8t 61j8HhC.W]6<9'7wj՘FSNsJM,`%Wէ%J>n=aǟZ>^&5wDUj MT%!VMawJ{Σ7'h$.tjRKPEOav߫T8U&T~ ~ps qme!Uf,`d7BeIP }1VOzVOvS82]KDQW'u}OS?HJ>~4n?HA+yO O^G:uXO$_W_)0+Ii7'WyZ4qJI>t~Wȇ+%WWJ[z_R糧KZI|ںKI.xKe+he]\|]&SetϺgI]&c2I$d]&`b]¸Umw$kOw$];?ޑtQ;ޏwϬQ.HWI\ώtMٮ#t|.wE-$i:檆e~jo^V5U5k3Yf drF +Ou_x_ g%!cT﵊WA ¿¿)zxWwNw i<oF|{~So)kެ._ ?))#9uH"A{(p~h =h [|S̆oo ׿#~}|-: _v\#zvmv~RܹvZ/W j>T Za='v/lCMm&? |nE6آf,j&ش FW>́,X/AQBd! :֚ĵPgtįOpC(|. ( ܮUzVIrdqeP`9R^Bb$pmKpdBmˌbˌЪRYQ\lnТ@ IF~8 ρu)XXo-,? d -raA6+0_[¼Fq^̝)5œLfgCMb7eBmMX 5P=+C6¬ 0+ř^*O`JqW P P<Pβ f^ 5'^_ym6Tf,3r. EQ9CDWE8Kaёe p9Q':Axq=ǓiBxnn>8;2q~ҎUzwzA[]rs8I0*"g(_;l3706^x[%l+L\91#<9Q7c:\1dob3 `(݀d_ym4ל8}K37ϛ_k זԖʵe勦[-%Rl);%R(s;o-^tlk{^???YY)wK¥a9\dKyK٤5\WX0avpLsr'Đ륎Ғ)T($۸BMp%uFYZ'"CPPnagۖ:*s}=O3fO#rIbKey9s O:#gQ{軅#TVXf*+~: pK?#۷c%h{?;wrbmk"]8tbhΣ6Ch=v>4UЯ O%vLJnͯ L'?$t>"wһHo2Yd)BGٖ}D}f"}^6Y\`bӒ;.Gr _C{0>I{T-Pe)ѱQ7dHY9=B-Pɹp9s}1 @2z$Y$]"S3Oϐ38Sį;L%rTIBPAtO^П$G> #1k}weIJ9HRV1jS8Aendstream endobj 477 0 obj << /BBox [ 1615.86 6196.34 4450.7 7330.27 ] /Filter /FlateDecode /FormType 1 /Group 237 0 R /Matrix [ 1 0 0 1 0 0 ] /Resources << /Font << /R250 238 0 R /R252 240 0 R /R254 242 0 R >> >> /Subtype /Form /Type /XObject /Length 829 >> stream xVM7 E/gشLQEk@o)Av%?=#{i O((QowLt6m}G}nyuj.H^\0$D*?Әͳ e~S:ڭ_!^_1MO]>:%q:|?Ný㤆R;O){Wr2X¿D V5VIg!emG~Œ W#m=_zɌjiSР;9*Y*ȥdG x\pAl}g:[SEA쓨99F'jp/[n]+l/q@%8>SlH v@F'ZL$159eoB'Gb0*ȦE̛V&`X,;`1 }8H섏c';]U 799.*d `RCy0C^,ٷ 1o[Uo6k=MY 2OL{c#fK-*[7rbl1#s=YN"}K9EI{> stream xYˎ_Ȧw`)p [!3L)Edٖ؂qNփbVf^^Tt?_N??NeTqa;]vBNVe1||uJlrۛ# *e?KF}ɩ#=hٟܽӗ/NojN6QmĬ߂-FŰ]mn7 㖔%X9d̅">99=&J&Ob>{$A_ѿ}{j|5B a x\*Os8m Q;U.ڤ?K;=*S0*೉؁px6Y9duDQ!bdaT0Ց4\Ց]Vzb=ﳠ)P,X;"E%L:O`I ʈCnډψǻ|xy\~%1e\4c*bPP Ӂ'̩d$P0f`D2d(Lt#؉^7 gQ, `r`ɻN@ʉCn뀎`L" Tf?d3)~,["Zf.r1f#W _y+4lF6L&L f]EL<)X-Ct?u2 ,ìN䤢0jhexdfeѽаA8cIf" 4`Gc+x12k^0JT ,75tBk(OM3KְARG= '4`b3!heZXI`z` Dl#u]>]k춀_#{NjV>MnOg=[/g+L,j.IXCd\MI0GWL_>y7iLNl?}7ydvn{:7k[7B+HEvH!VvH,,duda9(JVGVpv`udań$#睛 )+ìQF5$)_b@+aBSN*blްjތOF,ˮM,@';&oTS<۶]0fcm3CٷM{5!+N4*&L˳bNFSƬb+5j,h򬘓^5|foc5{TI#W$b M20e] v+X"hAYܵ8Ab);DRe2YY""ԍ34lT?;]CFi{ 5qؐqiGTOBURKVEXn6h#1PV`+JMV{8>MF*!%@g!D׆J)8ipyr0Ic&H={ƻ8ߞjdr霧,D@hs6): ƍsц}nӢMN! qƱ۴z_cDvuEi!2|ɔ# +z,duda\; Kg|; #d c`/ ޘ Sn6#&4&Yad`{8d)Vi `;7ZOȵq[l=7CÐzZ:BVOMd]Y56얽H yjT1*aTmz}0k.禽Y5 #zT4E2=ǯ1\֚G?0ȩD]D)`waP"5lFl+C2Fi{ 5qhgx"V^c#!W'pj`٠DWG h{ 5qȫ<)*/!`BUh2Egjr1Bٜ!ם9L4q^svA|Xb+R8Hԑ}&BBk"YuMd6Κ`)d`kΛLyr&&:̢ЗT7:/T)='Y>)U8 Ԟy7}Ow?u>ŻJ*-&ﷷwW/S]cq}G%$Oʹym>Cuv-qf% RG񛣥7ݤٯ׏-A, Z_uoo_>;_Ou Dlٕփendstream endobj 479 0 obj << /Filter /FlateDecode /Length 3272 >> stream xZmo6eUp{Iz4mmP Ż\IZR& MVyyQ~]/ٝɯ'.7W'_|RV'^/_XmJfy ,v6[lErJw}/񧮔sr%(rVɲr_xËu*;]:lEԥ3+u[K]2fvӴMY&+.X)X,?~\YY!K K܁[\9za[f7F*E=lQYx"i uKUL.j8VC:;mՠv$f m_z ^}AJp3*;=mw=2WX o~[ *$@GSѓ(br1bU*2MC]orRE ͦǺDZʂ–FUCPܷzA ެOMSYz2.j hKU36M RpݍWNva`S*^eR:qԼҀ?18-?)b1`2' - ީdsf`1 h #rDy0)^ *dՆL[24کP1J*S`@ZDXUIbҠ:uA9LvIU,)+mhpI%E«-ށ-OmiRP@<]\}\n2(߆Í0FX].ѽ6}ⷯ\;N1?Mq f.ړET.vي{LA(W(l~Y^ `tګY*ᠾ{Mu}8C/_٢W!#[*l %qz"Wtw c mf]mן^-=FG*7$U#N^u(T]+*pu9aUq#@ )&77tqP $^WG-mH\:8A*Uf@7MCb7 ˥$[ @Biڿ( ~ouoteZ)E}؝@w\FQ!vƒ+XN>2g{ tn,}q}pj_0b(C /ogZϹpeތ=o>3|T'!H#=0)iKLa4ff Ti/_VL=&qJ^N[ r,0'K}s2MкtߤDR"j{;3;ߗ'?Oz~lLɹYʕ-16ö<ۯ.+' /`3t7໫ⷫ1 UF)Ywam6K_x V̿%Z4b׬7fN"5/{= K(Tf?L)=?Òhp楱Xw@v TsaW%B*=mo)6HVQX̅qvfV{8ֲWRnnL JdʍTkj >Jvxπ,~ӉloP"|Gkm9 lo.+&f7y;zlT6BrG䨧6}&yI{)H2qqlO?G$m(%R*yc!|=ZO//?}qz.^&l(XfP_Eqwo;MKa2_S%*jz+~|WߠAިDG:a""EGendstream endobj 480 0 obj << /Filter /FlateDecode /Length 3706 >> stream x[Y6~߰bZOIf$l0$ gm9#G_UC ?&:*mor^3N_7iٗUy7)EVI81!oapY$ .r]Ҕl-J%;lwR, W, UOu4*Y~` sJc,aBgy^5>+XOcw/PM{ŹR?M?|AriU󳋿`WP77'XD8h}n;?dbwj~aPx曝(*~,q?ax3>BٟÛ(I܈vgJb)?9>n{H>_D(FL<^˶w=/*/^v2iQs$8BBu|>z%YGjTCPv%:Ϻ֞,٫-Z:? ω^{"+'iEnsYUTdvWJC۶("溄1Ng[a FREŜԍ0JW]8+4 9' ֭͆3!̔'.P(+,>ƜnHwb'fqOjO"j++/Gx1\,sE {~PУэźA=NCz*#@a@+iNA_}ؼ:PLf "ql [U,`M#8W.EkVKWܰ%ӺwG6fMn ;IsJ{U4C0Jx;(5Q^hX}374 `m4U|jn҂[\0s҉2Lx #ر^Q#k Ѭ@Z+$Ft%\zt@PHRY Dnc~tvY{Z:Y&0Ĕ i8&vc 2҃Y,N"89|j` +rq7SCeX~[×/r2ĮaL(r5$nr\P{!q!RmZԃd DRPrf4 vJL]5oiiŸJUƼٵ>yC.+zN\5<4%~8G 5 Uξ ( 4+˰&'f"4T:zi;mZ .npDmLXmS<R @98R*)gqC`0 ~.D&hZHZ&ɶpϑZZ>)a;Tc$A1#uoV qtLOj6 '4꫚7uz7 tA.8 jT?i* kU0~4 +JLfg#6'$%Eg!׊oc]J"AFlDP$⨪ԙQ4#D66j)1kN@?\vwMcx#s!0m'E.ڰM)=116 !1"rzkס7sj}vmuu;,O[J%G|e}'eV s{vΉgg?Ft۠ 6,+R`pЯjܷ%5<V 'E7%7.E>x ZSW}}ڊ@U1q%Nˎ]n3lde]X<~GY H4`sE"pS3|y -׆,B?Q/TLL)2Ybըٟ7ލ'&X_[R.m甾C/j;E(q,K6srp^)PY8H ͩ>L/! \SjvM3ÌI`XIE ۳&hJ}JD$ a-}rRa0Q`xˁNxF msՂvNP?K׌AjKPMb.'5۴]A- [o`m Qpo VϜ)/R0kHgWzWT ڀhƊIJ`װ.oHol= ûfrE㕌V~6nq*gndgLewUW4K7Tf!P=v'ϩxP~yDyǨ|~^PORڒ.4L>UH#+\, bcU*b՝c;Ҧ ca#xt8@V8`")ì=6YQ#C'%jl`Cn~D.V<: \br!ؘRX(.P#t;\V$3'z7ii哼5Gc̃ "i!ط~I=zz=4ݖ#+L=`f?Oom-$97RV)xXJ3qjAӾ3H HTwDai}Nx/ώdtPLoSE,ۙxG Rk'GyCb5Z^'E9kOTZSH: ǣKĚRª1ݣPRO]P~漉 wk[֞9v:om)MP;lÀ ˗$dn"RGS<=qaiP=~ul٤!Q6"zn ޣ *-+w[0KVCpB) t928Y=R8옿sڞ̪韘jry IN,s옺a7_U}_fwkZ}g,A0y+& Vt>I rO'o]ܾɅf5w!(.AɱhA27܉{.t1Ȭ`?-I)0nN~zn yG"IRsغ`4[>lϑݎl^*rm! oO(ZLi 7 gMJ@q<BhADJ|;47]W\Dϫ÷q10 x{XGĨro6Pm1?΍j =T$I1#)Ti/M@;fFl^֘?R{#էʈwT_bVz$OZ \7OC"Cv~nijIN^KL@$2?mm!I#B\H%Jd݄VuPGnmwBa?Y-_eExk 7MA(H\lvqplӚQΧP+ }iwQ^܁"*g)ʸ\XQjD4t݁q_(U՛"$}=@Ě(.m9tzVV/.uT5!){!-a#KbCjnq{Câ$^h;MHzaz'/;lԹLn6#03u'.Ymma(I: [2kP1>.+NNT!xc: endstream endobj 481 0 obj << /Filter /FlateDecode /Length 14049 >> stream x} eE.KMТ g_eQ`(D] U]PunPAq?pD`pAx P9 ʢ2S20県ȓ'N_O:Ȍz~KGΊF|E?NwYtX{_>?{Yw8a9{phNQa{ywbrt YuF0y^=`C8< Bl<ժiGHuUi埒>ܠ?JKywz$QHE~Loģ: äǨe# ?v#J&8N^t(zI(yigvsdgLEyygvEm :>Y>R?b$-I7LM2y,+3{ic@5 l񆉇42`2TP:[4wK^3 8lWr jEq/  6laOMi3){rJjv#0{^"WRl Wbijc'k0$yQ,P +͐YL)6N)F)#Ԅh2XPSCo*k+`=5r%WZNqM~D+ `5X ~mƛSm+Kpi"7),F6;rXzv(Zzl3܇ײ^ҸPΣVRg%8F‚J*6n9@/jiym=téіƆ!q Ї4.Xa-Ӛx!f='^˫yВ1,;JW֓x)?xY&&DiZ@{m㶱a{%! nY҉Bl"?ظˈ#agkC/wB8,4oL/+ZNIaVOgѕr%%̱3 ͚´9B$I̹gQ嵀,*Ik2 oo1(=LH/4uIBLYb)!dSpҼTZZUgѣCب8I a~fh@pb (=yX#ma_#o;o$qKm׉ڦeziLkqɰSkma aYM,; Mꅭ zoHޛv @ys,6odkL!`&?uCHm6Ұt+qGi~ :ki qou1 $ͥ.Mril:VmyRie*gVCl9U뛖"P(iҡBGjI2CIҖR$9d$9ܒY f=[4h+40ua.49Th`&Ƴ“;VǨ4{?z:Z:rUKtTFoO>X3vQCy-n_5M͚[Ju4E7 y<7QKW ZNiRk4g4hd4g>Dz3X:E2CE7/P&LCJGuWUzGT0T)ʆ BQElPF#UxPuˆB5iFeZR5TN$u߃ R][P8'UjcӀX*I*ԠIEYKR.UfVUyRUEzuUQR=h"R;)S5^eÖz6l\*-ˆ5WWoUP+bKXۼŢ# #JB UJƲPM[ZlgB;P5cD*qV*Ε*6閒]A7CW- uˆB4DWŖXbۤquP+D*u#JK$XQ翥JqmERR8xUwH( 鲡\\ܸe7aĤbeq~VW EIƒci,>RD#7{YQ*Q.1B,P,K%V2K R 2f)|KKLKesTBas ]y\lrU`RQй5p:ga2gqCJIP]Bjh1+Siĵ VH]ZvR}둁X+.OՖe'JNZġ:HQ"BY^ݏr BjbZ0*ZЧ\z-u|F'Tc mqޅ2nqޥnAN[{jk-N7r{A-RB4J_Z!Em]oZEKkҰ=o+o֡X|/P.쯣_R%Uދu* rCJ H,^oL,B߀{ H(^RTRo@m-B $ , qTo@bVҲ݀BwYx]K~5wK߅GK黐k+Tn@bt ݅Y Hs7v% HU X.ΎX. [JYJvPҧPn@BU:uqL)Fܺ'7cGS4ʵ˯BW/&t5#~cadpA 3m(y䩑9azD]Lǩup2&M,֦/LG$R Tcnb 2j@s] Ì ͆8Px8(Ο&=/P( Fxd0TACT`8cv9J6(iy8RR$"-B)DA\{Dqgd M"׼ĸX(E35=oqf4o@x^9y*hGqG?}4 ?9J4-QpB iD,*RGiB%xԷPFQy$Ҵ’!s=Ir"1CB)aXE>pQF" nnYVXMQc86 ,!*Q\i,4S ܨ:< E""Λ((MCN^ҍROq")NGQŜvg (M#sPFX1Jەo4pr:)D@Q(MSKr3FiWGqGtGiZ(n@y>fg9Jӌ(b: ɢVNP4" KTpfv&NS2 ʍBg[(MS0/A=30:A5VqG4Ҩe( 0PFrfpQFXQhe$IsPLp&f'hJ9TWЉшXd)>QFX@|RB)aE@)T{.=7(ԍc9M9[(-GqG0 P|L։r)TEsOzԏ2&0 8D=Lp9 Νub)'yG HUf*JslQFG9#f n`v0PVl qЀ eFN 3i o@yAeJ ^^i6Jӈ] 9paeT8D!GiaY>f8Jӊs' DI1DDr`}g>8Fa$ 11Ԃd&DFJ1QP93ݨ:/؟=릭Qs(ƟX^Qglz$DnDK#WZD~@54!(n|EJT6C8[QXp5tܘ# HPgm<3{%ӫA\"U΢y#8ƈӊDy2 iD, Yٗ8/oҀ‡&l#6J+!{dR՜FXQ[~f=( Sb b Μt)G4މrrҴ"8cJ[bjUUu1TASKU@8=R8Ҵ"TWF˳P֣_,1R'*5 .)=4rE#,W2:9VhLVY(E3(Zt]zv}Nnܨ:,4pZI(?Q-r")Li'Ȥ h2etF#l xTshY*JgBl;[7jzA*hՕq846i ŸQu^gA`@Ҏt=)Gi9zQsp<س}siTc{ERU.fMS|E ({V1,޴g.8Mr8(CoVUFy"Ҵbs}ƳPFtXWpI(P.ӈXNPUeJ(+ * &%FcjR,-PF8А-V.#:$B)aEA\12oUܨ+g4!*inIa˨HڀrGd<3e1gO;pPUpTARQN/`MRfpHLa4I1RY*"d4bNPf:B i1IAU1a+'f$h# 2Rh Tge5ă i R&} ű)42>iwa ,">H]*±hiC ,PA+b8Ò*h)R5} Ź4^m\ GfqY4*+M(b^#4;Qu^`ӢF^bX RG ,@LL*8I-")L"ZƨxC4"9GQj1 T<#6F+ |h EӜFrj8J肠(Nc( g4"TgEJ8uZlV4h2ZiQI3( HdU! 3yn#K4*gP/#)F*KӢb/k} i؍JðhXȋ8ڣOT`4b .PUB44 o 0uF֝)NreO h U@5NqhVi5e(*͍3҉JHB)qDy~XE#b1c:$OpaXE_Oض1jup2t}AS>FxcVLpsş_Q>eB# Ξv;Z=^d+ $*Mr*FX9@1Ͱ SGti Tg4e)8(*Hʕ T^`41GIQc葚$F#aU{;F#g ƞvoⴂFX@4uPPAueшXNPUiy3HeHTuH~i&Gi idE#R@*c+)W=@ DNŨx'"AEAs}}+)hdp.CrrciUxHdͰrj+ zS ijnr9Qu^XUhi sCZhJ!Qu^q^UYisP?Q4M~ۉrHOL#YY~U/`+' }Z(MRy]fLL!{)!;Q5^`n%mA#bŞveVFX@)Vd.ؼ~#6JI8r9JӔZ}ŧnP'C,Ⱒ(9,AyaZ٬WSV6dl,!>[Z4J#yI+hEXْXYݦ*q54"m|s^>א!KN쥽 _]ҝX2Z;k۱]z{ Ma#+ {EDEYtd'Yt@ǏE{/ާ,o~S#]nN./L^5-יٹN#Y{Gݕ7?ν쮟]wݹwK7s>m^3rN+[sEcnv!׿kQ3ɏt!/O/|˟?_O_߱~v[{~{cwއmͯ޵E<~ag?};_G3n{a{wvYw޽mC\O.[O_6C߲cgpv=K}a[`¯v;G 7/nK~\_[mϾ8}˃yK>=C6On?8w3[-Oin)7}䆱a~/3>ԏ}x߼?yYmqծ>7v޴ÞvcNk Ż/l7;GO՟nG_ƿ7Xpso{7_羶'vϟv/y<֛wM?얷]}7G78m67&昵wƞ jީv}Uj>;]wx.[]rC]'|/zǝu|?ug}_o_3npO_K^twr~+v #~!}jv:7G撓o9',ه>{?8}ʏ_}νg|q +?wNXS>пmZ[=됩śϽx[l>\wr~t}㧓ٻOxz 'k:fOK'\v|I;+ 7=f=_xO'38>:M♿_Gfu'?^~꜓?o>xqϽivw?~퍷7ͦ=}߾sᱛvڞ[)?|~w|G->Sk/|꣧Ρ&'6`㗬R6Kqޢ?/3ޘ{;Ch{Y ˷GEތLg1e`IwuL޽W‚a^޵~/`KΟ?;sϽwy}ٻkɒ%˗/_^xꩧ.䒋/-p[LC8/7!4 |SP7?ݛ_~_wѿ\C6߷ϿOcn1vtT'x|~`wl;>~ ~҂k#X˾ofG{X(@Pc54Ƒzx  D6LQůb.))şhPTX-Xtvtţcp կ\zl ?gh z^ .ć3!Z cx) ]%_jSjIMv @5"mFC<YԨ;7:a>a{YwhUyw01ϬR<2l@~y?JWLYu'fg'V ċ(.+X'A?W`L & Xu'=B+QCs$pUA UǠ?=15uR,gfu_A$Rtb](3~.Gw~,n L9)`rM0Rƃdic50FM@난ݹ<>%FFy]њEAwMȭ̟l}i1\?51(# {R9B2(``F)&r2qR/R.,Lؠ%=M=va`ZcX"NJ%ݵ KJ؝YVKo77o.m540e ]W08je }5_dѕ͂X)"4A\mVïK~R@Dņ5:SFQ,F3+f'`:C9S܀ WTOCإ41WEؒuL&[Uu=+p4jFѿ&蚸õKLtNXVU/0[\f$ {Q7ShGO4²T[?Lca_qf8%fs'ZÚs3l)f >h~ŀ,Gʖ..H/Ulz]/CISFfZ# mVCThն !HE n?X:N.S%ܾ]6 g:(hny-Tt(mu3Ψ#e_-}2cxo-b&͞ zW\jWS`R?,75/U*EHl$ɩVRc +frj8zaůfN_d(͊ SG$%uWkpM@NfȭWuȃQ;a }˦2zoژ*@H"m%ueqd]7l֪NOwErEAPԜbAwu)tv޸t-nZ9.3vv}Śga&C[ vʜ\_ k}8Q ,ԙ>=#AiTcTGn!jK5CHm?+n+Sauطj ?׌S~/=RDwXw;@ -c *@3;Bx`hWEs [ |Y]tCjIꢧ1Weu,S@ uZdiY=bNt-~j5} ؕv⭅yi%|6 k ~Ë.b&^i1H!X; krLاl"?-fY)LpgE~M*hԈz2P4Np9Qnz$uٷM|XqcTy)uĤƪj!$J hvbb)~^hHtͣ/-nEOt0S>;=0'*s}mՍ+ =?OTSG`ѯё^WʜPU kluA7L\an_,tPe@)-IJ3my1m&r$ =R\fYKar-nO> stream x[sܶ׿P?hb^cO3mg&m&LNLN뻣LRVܿ @Rt./ys:7go=w:8S›**v~q}f?ąTe^ u~q<{}\m8>knPdE 3dVȾe=kaYm?yӧmw 6otp釦>Yn*Ue/_Ide$d:Ϳ/ 2E(!tJbwqa\Ri^fkiO?ml,}*";=/$Gep;=u{ԧp'OEO;OK, =\Ɋ_!WiZ״p7~OvWwiuM, ,W">xΞp*{ 2^L;=ퟎmDYVUn>"%- yٓY;ǭIc/ac=t'Faxi}=뻧'@?]ߟ&,W(lw$P4Aڠjx-m)d,e8Oak/H:V$l_g5xˬyu{2$n~wxzV%+GS?. 1pZLon?kW;`, b RБ,@}N$#$HmZ L2*ُtW,$@mМ1 +ߍzYhPk-“p. t Mj,-l^n1>Dvn~{Q@wBri&r|nde}WK"{8Κo}܄*g6īn=Dz]T:,r.$Ę~,=Y\{ս;N% ,#8-e:ThE DSA?+Y*"QuBkjnnٻҸhp?߫@9# aBې9:qG- ޹.'aNcImȀݸUٛro ޾kcYaRuh5N!2{`QDn<C#bNX.a!|͵#PAQ"847`N}SYݕ BKAuI=nJm 2v )bۊN#8 ٚ =Oq d9fq k8^SG2/L@:ȴcFO1S9aAl;]q=$ȾY#_a' Gs#rT&v Rh1 Vob2 t),VO( IObR] ª(5_vC0ҋ 5Ƞ`B`D2dt8)c1lGiW 1s4Z@OhU銮!Mj>4 Wk=s O1>?Dj("92%9֢v;RɡDJ>x7ZS Uh;@h̋} m->)=",+T%DP'eݛa4S< ]@aJTw$sBeqȹ !qrZZO@'cxXJ$7~#к[}shO%o_i&Fek_ =Y9YAb1+T292 B'ڷj#x,Ee&xj)ưg$V$o3 G 6o1#dj>ExsAc@KAu:ώc9V(n- {lq2MN80+3}@ϭRs4p;6o3ոu׬ʞڡDdHuiXz(wB@`WeIr,"֓PE90j)JTT'KzNQǐN }J{MR){VIY0-U*(2 *8`MYbaQJ+( V.5mVκQzrՑq!ksjvfގy%eUQn`/KEi*EQAvՋ&4xBFIƾ Yٶa2eŨ| qS*Fxye MlI.`fx%qvo`; ',W +oF*,.a=9jy{ho;vqBSӌ])JrGD*!ca،ώP/ ]ƱF\mCP7džTR1NypRyxkFD9j& ;ua]YQ`_crE{B[]'3 BmzvLL"`8tY4Q[b bE XE/r67ْ$?O:2)@) }4G,Mܴhiލʉ> D%'Ȝv)YsYz_ߟvmf1(*]aP⸧v ޺HBkrXEٸn#)(Qj!z`K6 r]BhLlKn)%M6Q[V &e5̽GvԌ]2j5EVkO#ASi'LF>v%,bVM+6`d?YoX ꜃ۮ77.I<LElK0@LDC< RǒP^:TgxӇՒu'%i8 Qd?̃|mR ']Una;A]xqMvC0cG#b4,]5vOip=uA|o͂>-bw06%ĴA䕍w.lx1\Q"(e1vDbLLp:sJjnV/]pnf̕M"Ikw ɹW4mz/ D ҡCO;4'û?@R${b:iU0j)YR|}^%dk&ϻKi݅`ް_MLou0lY3uFrRk tM <>Al\=8,C`Z%y<s2$W 扷8ªHSWpk"DPV!CRFXV&;+U˅F ˀe\!pǺk Ƶ#"gu8}[ߺS&Y<纋F_.pE.4_VުmTϧ V{Hhyoۨ $45/.rƲ7,\f+w&m em*kCc=yDtOR(?0ŽIsJ,j6ktu~~~V M" epEHFfH'+8A@{U͈+6Q  !V^ϜצMcm vէ!Ce߯u 7/mr[x쓀ΟBޠxg\, UK!:xg]B-h/|Oglendstream endobj 483 0 obj << /Filter /FlateDecode /Length 2537 >> stream xYKGVD !̢kНwU|bɏ+YʽVҞi_33vX e@<H@X 6Ɇ_`9y$dYSUwj. E]o؎pZJHk˃{S%VRLJS^LCtm<.߫Sk7o +ФקVuMѕ&[) ڜ M t{FU5F8\3+3N@]/f7'.-ոhIi;!h>uJE@7J֕"ɒ`+J,뺒\rLӚ"ZXbn6|}̰()\TBJ("*IK&2\5yy܆J *&gh<\%3LgK/ŲW/O~r^vϼ黗Ï/xԻ??ŗo`?>ǧ|/<sO}맿?~zoիΔH9 "JqE[*4F+';8jG2)c$r0 KH&E̘JH&`Lʬk#Yj,7tBv(Y% %K(3v[ 2hJCdsn!9$6d=!`3ZT 1[T9ZiX5@/HASX8D7gvIF23AO# 3&HtHDQ ӁDJA"JER HDQ*(A"J% HD$= }z5s A).2$ֿʩG X DO4>N͢ ygtY-O7L2nKu4$aJevfqⵞI2ӊIV@%m)s1PӅ4h:/q(.Eѹ^T7ͻdz}lIѲ]U{FG=kӊʃ׋YpSgtWwÕתuvl8iK ]LOVj< * 5ٶ|jƳe0Pb" Qk|N=vO6H 4jm7ak-EQRs/x5EBgfN&sW#cW (RoRЎTPN &2uIQ=E\ۙ,)ݣ530iV7=A Sc(&w9^L c7ԇN20e1L+L-lgʧF7ɶ8s&]i"mUh2>YhV͙OM?E̓H A w`n3txlDđmp<(m{sF q_9qœ-LC%@ XMM,̞϶&pDІ6ؓrJ'|rZʞ1CkA s)s#]L,G ܿiͧj^ͼ0EϯUXܼ& W 26-bݢ4N-N`U;LΘθB+iYON*3GCXVOhG3*&19;A^-L|F] c\75tS lFOkendstream endobj 484 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /Filter /DCTDecode /Height 150 /Subtype /Image /Width 150 /Length 8394 >> stream AdobedC    %,'..+'+*17F;14B4*+=S>BHJNON/;V\UL[FMNKC $$K2+2KKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKK" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?usw߼P[tQ@!$$I d$α?H#򨭭my~[py}ѣf]kVOrUyqğ-YȪi os &U0@`z{~\榊2#| BJ;K穌=Z9VF+6e^P? C.d!St9)_!6s۩wlq0'ymFi)$s)lΛ<Hyc=w(،H\aH+&0!uC ذL Gnp&'\RѶpĦI}D2Y< GV?X&l=sTcj-ˎuV2L,A=zJ$ztWHr_wb?0+ FB*O)N#q>N)|,֬m cw7Ryo7p?>߻{Uyab7+2/'׵>)W*~D 3jZp,X $I*$n,c׹TV$lQʧݏt߶h5e+K;7~|`܃xa?޼f%]**1ʖ@x)ɦ|Ȁ#!q^6Nsw$6or08]^CW?W@ ] ?~@a*T~N ۷*7L0exe?L&ǧ<8ʯ\d}s>oSU(e4_&|30~c:`cUXD6.y0q~lA;QUBIj@G'(nP ՈM( g!B7A\=sIȪƪɟތ@y_?1>1r)c|q+gw㚟 n@)S9p3@d#]NNܓ6}Ip[ys?zHx=\?"B2meM89\sBvFK7x^ǿS]2(XL‚er 8㊨p \^l~\+# |p\$ `qҡhQy11f9?.F?uK6*nw.rd ,SaS~Rx~C֔6Iqی1lch#ar3u^T~ymg^Ͻ ̿.?E[4d.ہ |ܒ3nvE.`7>T!2z ?W;v-;t׾i(Gt FO@T04nKm|scBJCNn]xdGTd?81 Q >d⭩fHpܻ#wz᳌9 XfO 1@8w+*P% FFۈ2:qOX&;?,Gcvs&-~9q=OzṄC>l&=qls $R7[Ӄ0xPl0Ð|,6[|랸=F\F[yld1v'FhA,vR\2bm?*lZ ȸc$ q?^1.Dɒ^9Iy)w:uǡϩ |Q#{6y]Ó޼O16cP2M*Xq\q] O @lG;Q66PHl$tt9x&>_<3Aװ+A1A9÷63H W&RN\ G?w!sh ~q=v7QLñUWqRx3`x0GSPD:@ʉ)ܡ؂9=v?*)"WnCwq څ+KڋFHcq>'*a #-~CvT`Uv^yc=q T {s3jP~ gO B|}Opyh~@2)\MIO+ `$gkr>[?]hFR4 $Ucvk |iprF'bQV2 S{c+wS?++ 1;o۔u ( l0#Y\",qu9=(oAH̬K,r:鹁{ӄE;瑒{:o™䫗lƸPyTx‚/>ͨҳy~g89#~>tڀm[ n~sߥ"9e,KL*^ǯDp FHԇd+cޓXYu8rW_=Q3{'[e  gךl"P?7nǽMYHUXfBer@!.bCbNspz2P@F$lB '0jUB 5hՑn ?8힊G5ę> Ϩ}@9213),"Q\On>\J&KMb9|ͥylg20,?:;o;9c[z<ߥG|aSGO֊Xm:[ ŋ+n 2'cފ^P ny" OGHٺϚ tHP3}~3RF :COM }2qnݽsqק1)oCRHn(p>l'۞s>oQT.n,{<ݎzg{>9Yrg=qtWiVIc|.s^q|C`8wuӟv3;IԜXۓ>_Sn? c` [f6@\\0;3(1 'qw9x9w\w֐ JaӍ;g2Ea, FЏ`15U%NU2pdϖCd9N{檓s2y9=;w>+3 1l'q 4L$I7ۈsF8 \xw@烎NxXy' ΎA@yp`7ml1r?:o^!$)=֒5Y&ueDsPswsiY$}:nIfpdWY|x=Xn)tf &` O>< ˍx\}ٙ3ggӃ=S!#f<Oۨ@0DvÇܪ?d89Ѯ&G, $| }:J˹$Y'q?MDhNܑm0{x bU,e|jlp_hR #29(D9:17I,}U!7ɻ=~89ӷ'"Fhws|{cJ2ٔ ٌdỌ88"Tx;pĆzxCҥ@V0̬r {6iRJ^~qvBS;znzkDr~acoS}8>z]D3Is01ׯP"2`1^~tiq;NOF(@$=P4Ls1aI xژ'ORF}rsUF/>㓿$ :IEj؎'OW|,Ea$)v*LTR*CeqG<01U ;yc`}yYxNF>^Nda4m2OE6Bs7ڣo(0`e1bB#<EdckѰm§,08#|>"s=K7q==S֋j.W*n ^q~̨j$󄪇`<35 ˈ>ƣ cY0m#rH91`cljX116o }8vg96.Dy'vz=J9YLl?+y%.ZQhcʳab 8!p3ڂ"##F!VHT6ɐy=<=9 {.{dgzNJr)"iK!dUCB:}*&bF {rCgO11aH ~|\n6p=/pxi6{l#d JU•/GLc?p `XP9T`]C8󊥘 lykw~*Udgkl#8;?S;Bmcr#;JtrGOZDkxpGnl:gƪfX':nnc?c127mc[@f'-w,!TKiONqVgܥc*ZWh[iDIuoJXqCnb!DAV3`jtk8Qs /0?;42R8GzJ3񓊮#i1=0 \Y"D\PC`o'zdg.vco6=r*dNōfl߰݌ V(KD31ސ$NKmm=żeQlU%Վp0 co=x:&B3's89[Ǧ}i"%ʈ,p;:g98=ND#f2YGs8d}1ވG!gMK`ϨTHbT8|'[ab^IlPOsV9DQJtuHq4(21 N g3zcbHc6joUzcvӒ8rCn!xȷ Nvs;lgb\/:O|+F6}ԓqO1BGwy\3٢9"'wlthbjB0b:ìGn-Zi >c$Ҡ[6([j ïqemaF|?fO;{TQAeB1?gqjZ]h\ey=:|aƮa6?$S?@3?.?l{ճ Ry&/9ޛU>ӿN6(ݝvc;39OTS'ows|v7F!q% ?t}FbC!7=XNoGa)ns9kmC}gqw?Nl E.LIIFӁtm"p9 ­:yV8.ߴoݳmƠh3_g;<ﻜIXȚcf u)yl6&挛RR,^߅D;$b2O/v3vg;5%~3;''X)6TzvE?bV"`LJp 8=smiꙍXݥA8n~\l"lo.e3|X+|67SCE\:a%Ӱd]B#+;N,7ˆϔ1^T&; LI$p0 #oƥ0`p * l:QES"WCrAS&0{ZI-n7n8ފ*24Dvd uQE!FRiendstream endobj 485 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /Filter /DCTDecode /Height 150 /Subtype /Image /Width 150 /Length 2575 >> stream AdobedC    %,'..+'+*17F;14B4*+=S>BHJNON/;V\UL[FMNKC $$K2+2KKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKK" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?m֩_~=(ZǸpߥ{@9OHj\JR4VQṢ¨+p9<ԛsRUa@0'PZQܾ 0k9[Rܾ &Z8Ce0W_sXL~o®+}kQԴ^z_; ZPZQܺ&NYrj~{ԊF;֡q?H<ZLH?J\"ơ{W}­W4>QQaNϽBJV:S#`)$AZaюOjɱi6zSSvsWySoaOSӿֆT^NtSܝT<ԈG5]pzDa&Lٱ?u[޳|]Vrjl{҆_Ҕ0*,2P-=JV7V/=Fd⩲sW&UelZQ$Î;ՖN*=U+8+ʦ)M(3󪸬W+d:X)zlզKEp6ϧJz8}ϥ^ll!WEgi'WC$bjQQQbAP֋aOZ*%~M65{og+bej5dhk?JV-FWIsYTbZ&+ }=Vj&Z&+˶ңk.3tj6)Rac83Tn*6FW:q`zFWҨ[vEj#F.vih:UOg8?(8K%''}H7J*yzTÃn9t?Zk͉ȘTDrjfZ"'J3V4TuښQ5+ "ޥ"qTe|P<5SnAֺ&܏{;nNzϹnĬz`Z Hvcޔg?7q֤` `Hۭ08=z7=闃TsҼ,֣#֦aQB!qQFER:l*cޣaTZXuۡDGң|cMQ?֭ԱsT~bU1]0[- ~ @FGۃJWZq3r2wr?:@n=};} ؛+S994SK Oj*lUU1ӯStE"d}(D2T{(ҞAEІ2lu"2m9L>=}aq14cן~QVH'9p$ tҊ)1EUfLendstream endobj 486 0 obj << /Filter /FlateDecode /Length 7698 >> stream x\T" n4ꮲN1`AHK[] QcCc !Q .5b/DcO|yٝ]x؝n&M` -OU$aB w eDi9L>)0Ұ$`(F"<-JU;M*G-E0SUjXU&AhZBC'%3A*p@ F_8h1eh(ő,xnq0Z`L0'hetFɬץ(N8Z ɱ`'8ђ4TC{ZL`LxcTn]V⬂qNC2 ) *0F0H} -58rc kpWR )ӂ 9gqZ MBCP=vtuC(X7n~ݒBBqX(0Ɛ<:%ď_ Fg"sq֬uhk;/u*;> O{}^z$=7FrȵVء뜫3>]TŝWM.k;}vsqo}S^-{kd6=方u4M %vw (I-(80R!&J"r]+!(F~ &7n~ݐ ?{tuīZ|1Ū;=hΉc]z)xw5Z㙄fVfc{>DusIǵ)UoaEEW`g+umNȨLb_'ֹr61g}|UMx==xOFCI~I˟z==v]ownL8]mq ^ǏQדst3-aCPe gx\Iͨ~f>lObۄ3 i{;vŤmoz ^_y?O75bpQ9U:q2J/hq˵Q^fv-sn.ݱ$jaKN:ڹ}nZNi_.l_{θ yVo7=iqOژm%#W]eORwŗk'i׵'J8&ībǗv1D:zc5;/;ڦvz>(}3JM[_^<ڂc/4 bNhMű[!:ŲVq{PmԄ>>_2dmn/)^Tuؚ#T'kt~vZj0`ZS\ȸQQ -rMn,lЯkj۹Z;h`d:k?$lhz*qtƓk6Ru¹̯snFؾ o=J41G>ɻIfϞPt_o|5]uc~WD'df3q\yNn )aq8Ӗkvg\ܻE?]Y%G]x$sHwyopU_xVٷe0)Z]=ݏPW,#?#}@yD_>RY/W^߫RRy&uLằϱf/)z: /=]ro~Jɷƕ=_խhd~}{WLNsw| 7/%4m7X y|;-*g&CI#K01aLCSb@giG5}S#a5%R!8Dٌ'iRf1k,T(E)CT@?8)VpuL(qB`Khh`KpyЄF)C F)A2 ; 'K 0WZdewDMs-Tk\ Z$0Be* ̵PY`Js-Tk\m[1̥b0)Xпs#kA{y,ܧ' ͫ綘WHq_l}d}Geduk=՚d*g_N)^rWkzy;̂ن5 O5qsw\XGy=/107T|^}㷾ҡ >Zm]Wf7+hMDY+ 2g cxv]_m;[eX[}ͭK@.=W^Y3~ Ϗq!?3_d'ލٔױeZ#:iܠg.ddiv}xڹ7g)f 6ֻZۖ?bpĥՐ6c'/մf./FP.r}/䚡ğS]z;S#S`{-Yjnp"xkw\5jkO/In y̪Œ <Τ=5}|¸Z/{tq+:Fvp¯"V b*J V VoOĵ6VYl kv7}/)NIWISF}Õ&Y6)pgt zS~">WfQ (1D(1 3cS؎ \0ipw@F=BXw40"8|jҧ3ddZM֙eXR'5THtzaJ`|!0NH(msdJ07VI PH6;FFKؠ <-ZFkFR ¡ JI~@b&0\Cs_J9% ${8񡻃JM:G5 K78 Yl A$a0FàC[/)he h[je$([D2!<,%<VYʤ1V:[>a]EMbJ2-pW{/8D# (ç,(4[,v8 0 ܿk8i`'pBi6A{H)( ZVAhaHPHޢ@`B03*c,ƈcPD:h4Ɛ|Eh0HR Qmq,f޾X PpZTɂhr^`| &<>Aȝ"ىm qGܒт0{ 8;DpQ :>{b!Z^pQ!:Xم;!r`omlͰWQ Xv>[h(Z@v!8BOEr#3uF3h9mflH^N 8ufa&./{gHGK$lĞλIۆw0[Pv-,.\Z{w Z%#48.BvÐJ?5E F18A)~A,i;PY |Fx@=`)g4yޤd!`)A8[-6֙0pCuL-].\60-fm v0ԛaHb_H- \r,EͲYۊ y!%#-FhB>-58-l{`b'b*%1m ^0 MT.R*k!n`A%c*`4˃P[E3DoTМсCIki %$R'c4i@ћEF #}!Ő ,A e,6C`!Ʉ.Y@m%M|C{mMH6& ~L0죵x瀑 -mvUv 2IaP ގ0$ : 0t2d lED pX[n0(ޔ q 'Q}TG/̑n >sJXG>#[l 곤= YwU1K4SIԭg0}M8+{Й+mP+V+jU@8+ChX&j;PixΟئmDk]T4J]4  p^0A0Bpa⤆)GbameK X05Ġ@C 4-O tF=(8 ϯ:c,X j yĐA<,;4ʡnas4,"է* 94}wZ@XNEH2YiQѐ"^Q,Lqyr!B* eOɐQa"` Y=RˇWmAi; 4VV؁FI(LYeP6PŢj\(Q&,Y?$x0nwj-D"At#Q{cXQX[ڠQC.\ 6\xjH΢_]HzqGrH(`i|ucwH0鰒J6ȇ]Wad}Itd_x v$N9$] Pq R D<<% w*a7^0fMЕjj4RP^hǭ&VHI3 FkӓlHg!b GZZM0!Z:ئm ?Op{c6)Vi+NE8`Cq IA-c&A ,\ާ/uǒ%ѵ\A Nҗb蝼/MvEIb` 4/1/La|3U;&P, NR!#Q޲ 4wka5YzN_B ‚ Ovk lȷۍ1Vedts`u@K6m985M9nZ:B|?Q7 X[wCx$ΟxI6/"-F;> stream xWے7}/eT,RJRlrvbalnin,BQ=OJIT~]NTu1y;ZgխܥUjb*P字jq9Wh2h3qΔT6PpA4=!-cyxRQ&#cpEsxXF(Žɝ1Ȓ4UN)/MEFU\b3ҸPyme&bq(E 7"Z x=TL`>=o&Wf^MN2'm'4ʎ8/r 'ӕ#8!^1>8ݜ")JבrN|U. &\HƠyh- .acP(L>icI%".GT$AgZN` ; BZ`MβOp֐7Bs,7@`*B0zz,!pS%L*">5иŔ81KtʨQCͪޯS$$O:yOoW t6^e*Km$4/ !'A$2`Tvr9=wq!HPI6.v'D莅t 4f?`a@hԀlayTA3XPs5ACz;b} $ `w`*3;,~P ( =U)Æ\ ڌ`Po>ӆܷ\=m7$I,ǟ`)s-a> q B ZudIz뻩> stream AdobedC    %,'..+'+*17F;14B4*+=S>BHJNON/;V\UL[FMNKC $$K2+2KKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKK" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?pBߵ?$&HJW284n*U[Ό6JuPR5bs]/AY~nS簬U+t1ר aO>^F#p ;oΜiy>SH \mq^& 7BuSR;sҝ E݂:ВRzVZq=*㎕9;MlcR>SS+|NJ8c@Y~SJ7_Z"OZr>F2acU3JѼU©?0 dy`tu9E?01*r6.z$|³SnaYIjhFe SA:zTXFH欪( *ބD1D#\(" *TaL_ʝ \ .*/V4;v+?*0W>Y=MQE~U+E~TU~aR] r~aR,_cjš;,c#=(d E4f.k^T*eNxtEѝ*sQw75+| ?x?*I38UaȮ29q!8pxL+MHX8ZIAR2bUf)@5YL<b|LWR}*B{t(p85dȣC"~*_C{U Ga*uگyo_ʹETCZ3pjddTUmyUW|ο0L?})݁JD9Ud|Ҋwb8k>Z ,'V~zQF Z`$ R[T!;GJ؛\}9sF6IX`ϭZ<+;JZZF *#ZF |?yGCtDcJRh3ӡTi ⣗Bt6}¯uk)F_o޹eM.$rKɩozܛMY=o31d,QuEW(\|Ô i8STW<,v2X:yT ;UFҔ"[ScUVnnEbܴgHj.Ҡ1yaҶ T! c?uVH#J0:=jسzU:U];i:Vz$6[|*R_oJ.JvjW/"N0 R \n4ݨ,C 5#9Q¾c>s>#|aqV/YP䏭[*ENnX㰬&FҶ^W>Z!b$ M&d;p+KQb1Ҥ\ތc֘I٭73 WZ%??>dqs; \<ԭe5#Kj H^ y<'={g=hNzMV$Ojٰ>vMMEX>5:Vb*eǖ~*r>~jk,+jV!2S,kp(e9< Y%> stream AdobedC    %,'..+'+*17F;14B4*+=S>BHJNON/;V\UL[FMNKC $$K2+2KKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKK" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?~SÌ:a;|gץ}ŅW]\l:Lc8=B҆u,Uԁlu.{Դ;ԪVuhe~G5v'G=9Z|HfsSS4_E4(iƜ;N 4jp8?ZaɽSBAn;(ͭJnޣu\ y?Xul1wLITQʥGcۿZ>Ңg'8Orv,*vGRW%VSw/UITjaXz~*Hh008Y?®D~QEQM0xjVqsYF`ҲZpҜmjwңi 4Qp2W! *[Hlz(͢QM qӽZ*-xϧjȦ6{Z%eO|}ړGoZ9{\(ʞHqHq5 qR10ҞxTqPH15r"6{<*GwZ5F~ݣ|i8?(:ZP8?/Nq=h%QzfѴߥL>S#27!E:7nVbJ*&.85iWeʊ䚲tqQj%:SJ l_4N8LJh,s)$=?x"ÚJ=)(2*Ze&МY!Zh;7jf11Mqק8@(8o3Q}}^w! *[AzQqQ.Ңe>IÁQ,U"=28}L qT6!$ÁKM6U'Ы?ʤ'6OҐ8ŒvWҮ~Qͼ vq޲42ƛS2ǁSv^}΂ )҅8<ʞv~\T7֣ pð;vp2GC}T~vQZ%'N'hC Dx4ԅb!8Y=I]&55jB@iC^1bjbCEG*!1R?*k#n%C C#)g>_Vq}h1$~"~J|Ixon7Nxnv)OthF)F ޗ0Xqޙ+I4q6&Y>ROojʻFF9v_~-!,eAҁ'}xϥ•snAoJ*;+ץ%ز_Ҥ֘=?Z2~,cc֨&9?\nYhITq fy4?JgWF 0=Go3~?vbG@? b"f@<~3㞔dւ@~OJb5,Na_Y7Ersu]nȩb?EH*|n"*CLx)o?QSdPy7*Qw7($x"Kɲ>a|(iJd|v+ɶu袊$4srYŀ6qtQEn" [O:M6Q ||VCMGE iGQOBy,(01QEh甚vGendstream endobj 490 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /Filter /DCTDecode /Height 150 /Subtype /Image /Width 150 /Length 2601 >> stream AdobedC    %,'..+'+*17F;14B4*+=S>BHJNON/;V\UL[FMNKC $$K2+2KKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKK" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?m֩_~=(ZǸpߥ{@9OHj\JR4VQSѴUn?皓wNj\JxL75nzJS;¦Yҳ*w/J V5*1qΆar{t_sXL~o®+}kQԴ_sK{J/M)ӷw4RosESG4T8U7' Y" T>S kń#C84hA4n;@֜SaU" WVU* KE"e525VVP43fžW>®)y-M6]>ɃRAgދaM6F;UMdUQ+Ћ1eb183gzc5dX8_Ҝq''o9#ޘIV<.~VH18=LʣsZp#'aܔR!UԊ['KE&N*T?5YOjT'hlط*+:>yWW\Z"mԻ.=) Q zR+a( jW&UFλ"dq0RwLe qMo#w99R0F3HA9 ڐ#񊀒p=ű:GOB0zT9‚ S.6IPbSʦSHְ~[Z2e4g5Fl+AFG&Rb_;V8JLV(iښm?+@D©ID=Ξբc2*X6?j?**=zS$QU)lt@o1d6ƠB~*AOl3mKpS*QOTO6u^$CQ=vcu9oʞ?FF:ʞ1 .D>fh-=9j6rTU֩Z7Coּ蛲SRF{ա?j_ =6Oz nFҤnzt@D2CO?2O©fR;gUHrCҨ`l=z]PLeN1Jq9(`3}zS@{ҵbNJzgz*|{=:}jYH8hW,S~]~QדS5FzJ > stream AdobedC    %,'..+'+*17F;14B4*+=S>BHJNON/;V\UL[FMNKC $$K2+2KKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKK" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?,r;Um`82ņͱ**Jw8,JoҘM{R?EUrbֆϼ?jd7ox{RʢhJ>Q_zn;hmÏJZB%ZWо.[`U}tSDt5b~e?I/ܶj|w-?'qkоɾeZOVNr&ڴcʹ~b/𩼗U*-#d?4B| Igo?7 *v`H!}OQL 088ByӧTWO|8OO6.js=Ϫҟw?0 ZF)!=7ʼwC_GRk|)w{ԱUZh7FSa [`Jоо'jpj%)lB%m7F 'kpi1dgT*pqU;=*JF?֝]󎾵)`~t' ?:O hBMZOa~Ioִ1iyt)QԿ.U '`L )8b'xh~ozȇcp>SnԆ|?M?j60 x;rwoFn'Zә&rwNґlcqNBo${R\.IR@q!|ZT_4ǧ(_=jIx+r{Pda1p*'>r Pэ=h\7JJO?ʤVO 5Z17j+5eiv̀%cֹ*|L;%R;z%>O.w}^m=ilN~~4S7h 4ϧ6I]޵o™sW7<].?GJ~?(F9ZӞB0W?'BsZ7҂?w{Iw*1_IPTש[޿׭ Jv>Vi\:R?WO̸?z~Rq}ƭNV*3I#c yG?8Tqr'A9!q맦 Vk%Tw7ݭ5wn.c`ˏmڿGY%ӰKSqvm D4y( wƤ#qTG׊rj|̼ڠ v\E_b9co™sU7yҙuxy)ux(#R˝G͑."҃,jIy-埯PԒi~mp*j^S,Lխ )S1mzcܿMʟSY,rsYk]t Wj~aAVjGZ_K8MANv&8FTPhʹ?Z*W V=. ?z72O|߯Җ_2?-Ҵ|H8P:ZDR=K,ޙ.<ިC%qO޴GGx!w-ʍ=>/;kl~V)qzk2^}iccrp{Ӱ0ڳ.GWu@6k'ZޚOQ(P~TU#p$N.Ҕ<9hb~a_PLcJb҅+EBc>Tw=2|™rEβQz( +<YUksEEުZn=Ɗ+Ei)S@gL5[+4Q]4c-ƜWJ$ YF9*P7N3QEFMendstream endobj 492 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /Filter /DCTDecode /Height 150 /Subtype /Image /Width 150 /Length 3087 >> stream AdobedC    %,'..+'+*17F;14B4*+=S>BHJNON/;V\UL[FMNKC $$K2+2KKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKK" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?0H/9<+HM&'a*3X?Jq_Z7 :\!+1ATpup_>VW17O$|ڳjy;N﾿hdՆKjJQ8cVO֧īVIY~uWO?:K_(hmz})T^49K.[?}Jh7οS9H$ṧ/_ҊR,|Ҩ˴2yY}}?U}ҽH̃_U*{C.s?J`Ҵbu qzAӰ"cNڥzv`ΔjTA֮`֡xZR`_ko^;֓b^jpj[)#WK x6Pihet<6! Nƹi\el6z~ n?Z\45piCvoZ*ev 31gGO_jp:f:z{V}b;~UdB,8jAAj0[#S&⣧ZQQrҜ1D 4|q^lN9y.> >Z< EH%iT+/0K@#iԴ4'&ՅM*TNO&4mRV_ӵ^2IPJ헃۽^%v\l"'=ޤRp: \?Hwޠ|&Sӆ|ݭ)J֢ryuJR "Pm4n]evQb:qH 7vZ緽Bw#Rdd HxѪ`@t*Js]5O֔Cu6nԇg2x7{ԣfzԸ QU_oaEO**m/FUWA9RMy7d~qM?8?(ձ_7~QsK!>sRXJs/'bp M4"hmL9⮡;jӈ1~F@`NTLNաZ ƳuCީgg]P~錖uVFo NTjTֻlY\j@WwZ?vhnQPtT$UM?Q<=?R ח 4y>xKGzձ$ϜԄJy =j`p SL8_*:Ʃ3;[A?1Jo_Ll?1|=jD 2<~8皫𮈽 ԯ9*.{ҵLPx#҆(LzS t;Yj*2#< *l]PU?r(QEy:FQp:E[Qy8hC&j*Q*QFނہQE4p7_J(B(`Wz~TQ[bl!~UoOJ( WoQʃϵSBdnQQEhfMendstream endobj 493 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /Filter /DCTDecode /Height 150 /Subtype /Image /Width 150 /Length 2964 >> stream AdobedC    %,'..+'+*17F;14B4*+=S>BHJNON/;V\UL[FMNKC $$K2+2KKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKK" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?ټ2m"L~]=je\2?yTo?!Y6qΣIl=]%oWKܚ}D,qR~B4PhwSW?AU M"y4B~&Vڣ?RsVHzקDdҟF?FOp3?kҤ3Cҙ'OVn-l;%i8S2AUՆ1F"TÀ{R [p㿥OA6R6[2qW|zI_~֯|jh"2~4RPi m?JE?J˺wb%oOҊp E!GT sB?Nʩ#=:lYEYPF3Mji8iwblQ$W*$-Oj%M$VyʟҴѢ6-#I2x E@Jt%PrOz=?8J ֥ܔO jXznR4΋J0}?\NoW3\ZLiZSUֆ#ޕM)j ZvpJUqJ(; ȪLSSک:A]Flt FdEA6܎#(AZ$EőwWICGE8‚{U-"$JMW'agSܝ`(P1ކ;AC!#sR7CH 1cm#[Iϙ{ZIU9$߼l+ .x}M+ ސE&MiOʊ\)]a^JQeacERp?1"2?ʕW%V>cC+Ƶ"0a'4xՉ #q$f+Rbb Pr M1`~cNbL|ʮGqQUVc~_O[PjozH&eIōI>^pƱ4d|H996OB M e4(ZЪHH7wYFU&*yBm?ot=kM|O)LoCSͻpZ\U]W*.pj,!YprpZX V-DV85VD!}kC9ST^ЁGmvM dL?U{:v{++IL|5q҆*"R :@Tb*b:6}j=׭z*,e#F6Jtaro>jw}ӚD2駑UM8Xj͌wqy~+i|w^w_sY?תRi|[`|z89 g0aAJ?ިޭ.Tb+1RGg?!T;9&1IV񊚻ɷeO?Fo'?P3m9i4KH;MK0p{RSyj.jFwgoCEgE(֊Iz*nUIۃ׭y7dqK$󎴻Nb*~n\nffZt';ԮyQ0n7R`Q>_^F}W#gZ|֨I2+g<ǞݩZղ+sgTQHn֊+DI$+&)= %Sx?Z(1y*.*SEtQEmD|֩)E(M&o+h+7fendstream endobj 494 0 obj << /Filter /FlateDecode /Length 2848 >> stream xZ[s~o胆3,[+4382$yXd$$Ads삠^;9ssߝ}ڮ*V\}j"s pPRw˿MRD4a -ܜ_` *\/X-Mq5]]Le |;_(.\ rC.}Y4_ ҖMUtUw@ʦaјHlkMwl(ޱYLktџ"n~ <9F>ۃ9imWvL!MWLn8Xwדy+۲{$ٕž+8h2tV@ջ]fbL6 eI[ՇޕC}SU(<ZM9նfRo AyZa[a2wCԷMS:[ae |r"붴D__\}K|b:7h"3}@.3_w*ؘI7\C>JR% aFGz繀wO@.3tk_=QֺZRj4q{pT>¸ 2g Cggpɜ 8Щ#qPZ׮p7> ^T)(@2!FyƏ+:W$fId'5UJLS`(IY4 3 z( Ş$c=y'X:И Ş%Z%XiY / ZZJjP蜻p7p( 0MEmOvv3Hljf">s.N=MX%M˅zMF&QU`Zgx.x, Q=.Fa9TcV1&C2RC1\ hvLNjtΘ ݏC$x}(L<2Os҅4IE sOeElSq꽟< AȘ8$vXF#8vn,r9;XVPְۙ:T:^.Em'_,ӃY#@mާD8 ꦺsaJ!onS`&Hxay\k/,$¤uM,ϬɄn VPoVMCC4b׸|&&TӬo~i%"W,pqUl T;f~#CSDж8O7[LT NIYA~|5|UYVA&\?\|]3bORnr8͋`Kyo S?`Y 7"}<4f(BvS[0C 3xxI Yf3)L\P1v}?N#3YQTM$8/cϳm"Vc-'xs:*'ARc} )T3X5јLde?&\>z, hiS;C̱̐HmΨQc3GK RLT 0_}ÁHϱhtnWtM5.S/L hOWD! ,Od* 4 Q 7E-1 7Q[ȩ obeGf5,@v;gMRզ'2 b0]Cbj(SFla@`G[) ] ||\]YaKbN(j0jS; }lfOzMoI =IxxS6' ͈įK0t;waƭː>*qJ~47ϕ8s)(M#`O\Oȑ31[ƜÕu:FgԎB:։]p89v>G"^wïx5?" |bu|̦y=.,]qMix.,Fb߹{/~BLF׬0Wng024/:ݶI>z8gb[iѬA%zbdԏkaC+}F?@endstream endobj 495 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 318 >> stream xcd`ab`dd M̳ JM/I, f!CGO]nnW}G1<=9(3=DXWHZ*$U*8)x%&ggg*$(x)34R3sBR#B]܃C53000201012~_I؁{͏kN3~#XlMN ?/)KJ+b_}2?S:u2ض=tp-<{ p]b ^&N>óoֲz'Lav%endstream endobj 496 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 323 >> stream xcd`ab`dd M3 JM/I, f!CGO]nnW }_1<=9(3=DXWHZ*$U*8)x%&ggg*$(x)34R3sBR#B]܃C53000201012~_)Y{ӏN3~_Gئvkb_ޝ+ڝ͑¾lzٳTR> 7s-<{ 6qb ^;wq {'O]wendstream endobj 497 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2653 >> stream xV TWȌ@Ab3Y[_T=En+(j Vр@ #ɟ%τ$ FP EGEtmٵۭ]=mOmfr{_Dxz"hܲ+i+*}s ?Q??+!h/g|-h8Go%"j:TIQ&gg✙3g<>Op<\Ѧ᳖ϒ7Sd*ING%ȣ#\9}o7AtuFD11IJE+""UD0%B7E[DXBsermŸDhV͞s<|_d$5:;&xL\->>ih?p:W` @(iTFs$0r"3pfcalx@MoIh0Y"GjװB+NKyb: 8d8rXN5?عkV0B!`q\(Edz\ݙ}6gH! ѬW[XPXgC0puHc֔), +fo+2z(`wtlv|"s .Tl`'!3ӹCd$lνZf[+B$Dk/ OZ9+_~ ?VڝBXH[¤'s'tZΘ= 5h9_+-YJЫP=vu'2qx  Ҡ`aL슕0AE:mn6v-)Z(f e4%% P۴FKŵ[N1x+o^J;$:WP*nUktA*v `[3Hߺ7ĩ&L LWf4.ˡ}f[b]>! 7d zAG.*ڮ/.32)g»orn4B$] ||N+Ⱦ6 =-$5hֵ&;aIt/5+PZqUF?{Kg^ +K? WG >ȋgIPk-^CVCeYm-C 6e*8Nj/n;<) *m)td&}cat):AJҖG7u1 Ik~(?t/$ ] ;U6LySecM5:ԍG. =J;J!Uv44ն1B@H %%f6sml5ځY,ߧ+_o:T?no>#Yqa1IVERFtSBYM9y zV*]D\E<,r+ /b>%<^,34ރ&,A=EEJ46-͢Xg0Ki^vI iu`lxFsi;:٨#ᎿzN֊Z OК Pṡ֭_oØ6֤'HzmYSB(]_r!qOx5>܅[E ?!mtLGt7JU.Ἧ0ޞQQ}ǀdWn[wVUWTV>Exendstream endobj 498 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1830 >> stream xT{PSg! \ҽ7T,+]c:BmX[H & 1E`ES,IP*eGf;[,;m[:vw:B?; 0Q&¶)YcdpWB8ۃ@,"DV<C0L(|k#W\VEGDFZپb p.q V%"ߴꪘ?66zirlˋyhG֤lӥbrrIE!nC# aN_ 1Vho,Y=+ͬc:HƭcA}dGfë-`p}e`j'8 R64+&otZ#Tvh9>V:oSu xhsW$fJ7b3hot^=|9 C S|7fT(&cړeP"x4,1GG17n`WRYkĦآaP9naVT4:j-A'/› ]0'[;ximW\(#NFK@as7\] t F4 K7L*fZ)Eƪ0>b!&zPe$7AexFaǗj)P 57,0db[ՠV[jUC6@8{z] P\" A!_/0}?~̏K#UX X z{9F;Oi@jʯEL}s]o}^6~TI:籂a?GGKcƻ{IH$ IQ(g)9rAo/HQ3˧>W齍O=&Kg' U|}5pN{>Z%tZr'QttP>LMՖ# L|I(ns- '/ (5JPZt :Z4܀{2WI?Qnm-o現A$fdޝ1 ??J}8iV|ƒeCQm(khI0+ŸqUԼ_ A7{ ?-7o@@A!Oyfo&WFg]~ ,!Swh~}<4Oط\t!){ )9tHT+4j;o`Ї?D]~:wP>2 .r+{^Q++:tBMT,wM]-~ ?jVи(_n YN&tlY;kkjjl&da7l.endstream endobj 499 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /Filter /DCTDecode /Height 150 /Subtype /Image /Width 150 /Length 3147 >> stream AdobedC    %,'..+'+*17F;14B4*+=S>BHJNON/;V\UL[FMNKC $$K2+2KKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKK" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?Y4(IqOvu?;:|TܑלtH3[#?6GN.2XJA!cʗ=c/SheOs,HdV$ɪ!}R'#:z4Il8yUM [F{ [Tzw:R+tԪzP]֦C@R)^ 4i(!x;}e?&?id8OOD{sUB)ss(ݼg>}qN;V}ccXaeA}:`j#chmz?lF}YRJ&SRjMJdS@ J*TPRJS0So.>җ ^59v.7uEr5?)}2Da>E۴I;Xlgbpz'ģ?>H`dtNtN1[kAeÔQ׿_ZYGOZ JUz"I:z?JMUWJ@SMs@TUTP*zSŠj(춏܎O?3SG#ojۑ:S? Ok,yFjZbcٜfOh;=&Se^G}6H-܀{֦Y.8?v67@zaXOrPBGok9_mg*WGzTzu[z =V'\\~US8:Hu[tZS?¹p3֫q\dҀ:Ԯ?{QjGW88rN7~S-ӿb fMmܘzP?JkZҘHR "/n*JDҀ8ms?;yNkqO P>LN3hINA\Frp-dž?VOܑT\cMJ1_9PwuThJE]FuZGnϽ@J*·^MRW^GoS}4c`aE!!Tp1s,~a9<屌>R84-? sۧ\^=ONըdz VVh oSt^iDQQFo@:t:JiJM+@PRHR+:{ʭ("cy1B#| ǵtڬr;!X1Ҁ269Q2u}vgn?*|ig 6G wGz c9 y8qNhv:'1TFfE۷jY3xp/3?Oα8ןUo݌ N>R_t![@QΛ~P3ڊg=!4*(RSmEBE1X*)ꋛx+vRM̜z!YĸJd>Dpx=ION2N{w::t毴K_΢%>:+8q>K+gOq[1&֩&s>TC9?w~^k~^|PyxϮ1(~|A-?nx?ywʀ6"`QTf1éE{In)1O&(S{Tئ@ZHO+.r8[W׷fN: ¢uOҮ_ZE[@̽9_} \e{^^ޠ W >Q۷Z[==ǵk\/G-R`GI}P|v79Ts>_?y|9€3$'@ܟ#O3g߷z3|GOB;n|=rLQ(ҴQ@;VtOJ( ۯD?E]ߕE$kӁQ@ M\gEǐzr?=j腁wEG}*"*[;v:E 0Q,*(endstream endobj 500 0 obj << /Filter /FlateDecode /Length 2057 >> stream xXKs/Ń`03jM69[Z$Xx$yק{ yCJU6{itlӆ[ߩÿ|fQFۍ>BnSC!1AXp2N| +}FBRH2UGq)]g,k(#̀B,d_ %o‘O\DehN`FQ20hQ#y Ӕ}8bq$c 9GRG['RJ[/* q|%VMȭ= _>?qf<ވZI0ĉX+m$P<:Bg0zS d&e& tZP,6tӈrP DqB`/bɍI~~w ,;u}ټ`qπ,H~>׿R>,r`-@bsJLQCiǪsa8pL NOR=t^{VQs"` d4ɹ .a& }X;u2yP$ϱˆ e:DH~a>~ּ mq]P!Đ\l$f1*W$} kr"WXXSm2fODk_ o~Cn $h19IFP=0v).SxB~rQyCe ӯB"y Z# A2F޾z[ւY7^\ Al`3s)zui o)ެasJc.] \h1sk6mpx3g?!KjwMUs+V*<_H$jzy=4{Yb*Õvm^3lXX4JLz)%./r+7uOMMi{G/Uvm~zfԣ7xyӝw}zp$Wé GZ_O+ibwƦu(v/[Nʁ>XD幄oJG'uTVe1dсxl9 ^m:]SZ>*REbo~pE.:ƊH|߀9 A$lmXsOyip}FDj5VTq@r'7Gn[/:߰{{5ݴ HV̩ uN/Ĝ?r,kM=MEeӹV'I6/3n|{ﻹv~)V,m?]8vρȣ&ɔ\Jg5jrendstream endobj 501 0 obj << /Filter /FlateDecode /Length 5843 >> stream xŝ[s#Ǒ+FLo/fɲk2HʲV72uNfsFzq8Kg۲?ۇMsS-W/n7M?_)r7[Xmn(>lvu!C]un}(q||M8.iwa U9Pq54.7O2?m-=`WE; ۶n۾U}~}\cS۟)tTEvn"ahmݍ4E]NצIb:b{ꦢj^Lm_FDMSYm?&V]1ЙYՕUZ%4VZPj%Q3[j5%Ou o**{)7S[o6uY&zK}|u95y6TV8EWlR/;F^}S4A+M;6 []5̣gw"XSWE[q(JoJM5 UTv[ezWKS1T6VEB׶kQ1TS@6xS]U8;USXF|5M;UTmJP+xi65&>9򣡪l4i]ԢǢh7&W7ԍQT7L{z+!OUVs/ںJAهz":]CÐ@ٮT8ԍ Nc`D@ʪkr]8e \GUMus%eaK5QH(fFu(@ \o 320p |LH5*!<̱RD=/  Rs)`K@*1\c:ʧ;tŃ i$Ń{*/QP|`(˂B]|V2H 1DcўD/$ɗSkWNK@#rUXjdj30oc0*$HDVH)J g* V-"r\8l@*F 鿢=c>1V )3P= B{V1gE8WTp'䉢}H>j vUjmr(()qGiasm^Rk>.-#a`bޙs`>)2H4o I$ZYHsZP1J sѲ+d &e%Z T)Z u IsfyO:O~…~x,sqM^o $bC>%iė?+OKvϔ \k30p㪃 `JbLpnf651{ L`Sc> m:B '7R*b{Ɇ5}D;­\`SHA7 2Yd@RG*־b<  p4`L\'D@TٚA+xĕ5CJ" SPdv$ 4e[1`KU0 )+7|8\C*< Pt8o@78U ܆F%pd| wAL7bppcL9FH<6,{ٚTp8〫ώl PgLpC.() vZJUbU4. JayWs%޳%pϖpM"-SZ=Y;`>~ް`hTў.\ }ik';EW. |(.Dp*`_GMVp͜πQ[ bEa-' Pb˧5 W J`4y%8Wk9H\F`x \OI.PA N14 M{=!pU#g︢P( d)^)3*)|H 7r]Qx/$”B(>TXp*<P|Go |KEpl^0<_py 9+~h]]+Z,Qp]3ί|xl ߙQ>>8fDZZRBD }ZZSt(Z᫮,w+F RCB g RM!pQJ J rI)jOJ g Е¹RTBQ%] K\u8@7Jpw\ +$HC)$^R|N;XJ /+%,(NIpF JD FC~ ҤFI74e7s&ȫ9%d礏qۧh2Ӝݗy(ø;˿Vퟏ쓧avw_t4.j.g;,Rk_Kqxpx;ƪ}y:k5CPϟ㍛L>蕟(CSrVEׇsBh|}8OSZeupgSw}wOk Ǐ=] vRy'#?n3p'kzn3>?޿7GY<pH\c3_7K7oG$nNy~ziCao?x ܹ9vMO{moSOHz{zo-6ۦ{ްRSΠJZicXɚyyZsv§2/H|]2!}5w˳iwwJ[]{uXֻ~IO{{b}^4T9<=pv7?%TJsH]WQ\~|_ *ܰA>)n7 *|[g**3\Zf,hٌ, ? *n(O" 幼&h-P(O\'#QD,̓*$Γa^D s3UW+xL I{ROV#J.)*جRGYbȪ4z<.b";UETAMEESA"U]L!XnaǕ2.@H`WQX3\J7qk8u(ح1(T}X05*v~ œ{)J|F֒yTbg;6g)wɲEARWPBBxD+?`CPˉ8|W@.¯+h`?bpU4 ?h~H+R>8oolR,.I0DvCWA%کƥ^L \9y-Wy9 yVIj8uePEumuͨsPjVֽ`ޠ.c3k9^)= ٫ZnR%A1d]RSiYWEyi'yyc:oS)r/}n&tO(fY^S&2&D2?+qRa^S<1O4xBM ӚRLYkjtAxz08=a5u~5w 9{'5go<^?x͋\If$lSK?'it%7go.aI}>%WiR4iRn.M.LbKs(7]SSv~Ev?f{v[Zo %{z7Hکx/?bzQ&OOoi؎%}AQ߉ݾzjQe8ZY~P_RSA;v?>?~*t]枋?m\endstream endobj 502 0 obj << /Filter /FlateDecode /Length 3262 >> stream xZwܶԞ>_m,I0xvm'/͊ w)e M^`7,ޜqz>n\-MV%\| :J7dzyz+(vͳ\˂%>Ynev'\xYJح,Ⱒ%{sܬT^nU۝"aO㺺)uɞ:ITiAa\qÆjNLDJq:c^kDE;f'Akທ۝DK袽=MrK'qiUgMvwC}iᒍB%T}W)lK6;e^3/ʔ@l!LFu9_}Y )ؗ!wzvqSϔLMFd >lcz/%@Njr,v Y%I+&ػ0W6.uh͐H0]+ qD-&̶;% l.W$#7-[ -FڬZк)66Ν1pNT`E.n\:@k$ż3rbhrr\zh8kOъ+\q&UJ)AR>t;`Oc .Y1}{ʏZ@MMl)ͯ$׬G弞o{4;6+ ] Psk^>.bqzNiȠA+}׃sELAoa_ {' nCQAiɻĄXm\6(&$da~}bR+HW9;_~հ߬Uu{jkţ'?:>rȦ3Ϧw23.ɨtZ;+,,"S—ۓLsE1?T1,+'n Iӷ6t>}MTW{0 ߞO|J_R"@iڎ[1vӜꄖ!ޯ*? V>s>YhO7(Us@(>\(!xIp el#t^۹~Np/@P}0@smRsLTzP )y΍0FUԲa%)8Nq(֐WZ'2iXkh[mRUuqu^zm=:TrPOu J=~Dp1/м,[ `&ձmf1S_0Np̢݈:VJRVW*Wq:G6Bz@ Urrp=+ rbI/`R|ߴS_kHmhЮG{GO uH"&fo]mGs>8Rq}ϛ } ]]۱?9~åiw@naJMDd97Cp<;8NgL:z Q7vUxZ{yZ-v]P|n= b4WM3=k m<:J|_Ҿtg22ѿؕ%UܢC)kQ~Cq[ $^J BcUQh4Gke1_UL\} 0n͆ঋLz*Ua$΄7؁¢"|)]fUn=kG 9AB)qN6*ET^86M<`wuT|Ky-̚ow{b֙:Rdgj!.ф/a²iDJ9J]sR P∩QtnjHJ8!`YKь,] o9V-2afa$c-85ytybSx0LC[<.Vy[ _ ]]Fw*t-&=E AS)s7,ǖN4!vڏ&n`H(N 8* W|``n):=,>rFō~ݑMJҲ*X,W·ALtŽs%>U2MwBI%\m0 jt֛iÌ&|3݄|DCAi;@~C{*s. q?eRg^M\&2 ǥ]yڭ4$( z<`X>;dAn0MiRJwυˬt@Z P4hJ yYȘ_C&6!Veڤzq"_|- 8ҙaWUkN?g9o"2&rHa)*\eLULPg@Qendstream endobj 503 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 371 >> stream xcd`ab`dd N+64uIf!CO/nnC/ }S1<%9(3=DXWHZ*$U*8)x%&ggg*$(x)34R3sBR#B]܃C5P0000103012_i eO_^Pw*ˋ T\)S^m. =wnw6/ i^O mӺvKc?{oi~}/.cA<_qsg.a][9\Ğ{z{&>&20endstream endobj 504 0 obj << /Filter /FlateDecode /Length 2001 >> stream xKs6EܕZ%KڼӼiM:(V"˓ɿ/ #\NN&P:#`~[!6>Ul?ՏoLxFzOu,섒ut'ZwJA ]וmا{?<*inײ3bP?*1pr[%6¸ 4L gORR&M!5 @ m8G^iJ r߯*ev&_ޝ~暵n;Eu}+ zͧT]'\uRӤAHP?l 9 yV 38Xii=XE TTSI*IۃUTX'jM:bI) A) A) A) 2S,*)E!(EKN((E!(f/)E`Fieve8)5)YSSWI*N* %8X* *3 + #gT,GY[I, +ĢQA+ A+ A+V V+SՈ*jUʖ+ A*ګdmVQVVWo^LbW&YgEj ~IЊCQ+E8PCQ* )eNSJ˔QQ). ^ĩQ#dT9)%(((xJNQJS4 NQNKJ$(EmRF*љFPÏDNq Rn%(x{FA*%((hϓT4 R'0X{h[SB8BXLu**BXv„󪹿x< q_7& (@Ï'<43$I܋@q,wR \!Iʞ/H6j^+p'Ts(ZUݬ/ Ek}?/d/Zf7?n|b{Ni.} ?V}s*en?7M{fd]\t͗Ws*vBI׬o7BjSoyzuPu`Y|"m(idxv N6V}*$EUCqP\9aEBX9aECq P\ݭ<).JFzQEYQQQQQQ JFQFQFQFQF'/3&(%3aPgQEhVRLeJQJQJQJQJ1()E!(E!(E!(E!(UL)RWI}Z ))()8)H)XF+YE!XE!XE!XE!Xf0YE`V03cdU9)SSSSSVBBBB`&**LJ/Ԫ1T$eVPѪ*Z5CEfh 8PC*E **UncQrFrL2)p@┑ A A A AKav?K*e$b Ò147:=e(R!NA#N$NA&N J,XE$VJ *ŒXXXXXW JZ\+NA+ bIPAm/Ϧ3Nc>+v]?==毄0EjknW{%pF7j _w8"D]cS*OA= ݹ,vtou 7{ T@^W`GLendstream endobj 505 0 obj << /Filter /FlateDecode /Length 4465 >> stream x[KFr>{!t !U#/Xm;0؀T5`p4#GXU;$XϬJxp>x#mp߸Ծ"n35m핹;ܼ{XInujԍQh|mWk愳گJiT.m6b+FZx%;QW㵃G|.w~x {"d_ jկ%NwF [շw 2M*l- JnsSIf]+eJ; 87<:taþWInn(cѴ{ZfLՁ (*ҘrÓ{pHl ;iӧs.v{z;sL7vvvN^}6[[u6_>1$ደ0qIP!l6VZ+j 6ۻ?˪~4S8&Â-qa`gv윔UL1(|cXSPZR2i2'4ձ#< ]vc I%!ԫxX 5޸D",fND-v IkCUy@yA4Ntx'VX&+&;+^jHmWlM 0Nc~mˇ#8lÏ5°j0C,hCpGFHiM_npr̉[ۺZ59j{#ܹFul.\3S HV j Ȝx>M EȆp(.*ǘ*cFK uv~q2+.Ym\0+& ԣiMwA i7/d7Žq1 4pJɬ~|׋€윎@'p as<&&;ݰ;Wu ՂI[RMBhѧK~ZIK rmɜZ&Wߛ`g=s;px`e,> "K T0s,e`Ԏ?IXiLXr6$i`o ݒ'Eлǂ1 9h! ưIhtBs|l=9i5 Is)f&=|N)Bvώt#+ɋ3TN~8-X3Y`ݙP1)G&*'cO+?&>_% ۴ȮbnJި iəO%ϢL좟i34 0ͳO=]/b )KEdO๋X?'@O;]n%2N+7fA_B!ۅA@H~SR(clhn=U;ճ2:9lWgȓn؞cOFנ9rb3cXwy!N6(MX2Z[ܱigy>r~Iu5|,&I`DחprٸZLғuҩ d!=I\ga"_qB"ΩurR0X\aMQɰxpocmid['Meéѡ&HlBEFդH1\qzXK Sd iSVY4`!-A'܏3\:p.ΤppB8s!jmq,/z}p v8*u8p K7S~"Sn0_~1:d;h?O 1//GЯ=q7՛OݯE쬪ozd3ѳ^~[o9؅6NaiH_VGSgwMR n7(v')ZElf"<"bvrx/" <Vo쨦 B+eCY" >O[3ԦL6}@@`)1#'9r'VL뀗v Bm(˘C_(I1{wƺ&4.sH_3NPRq3a˯GOF5]76LhXc26i58l+opޚp'TH/֫tX͉+&:; ?<rLƳZVN:x3T"K@1!x6GkО1Xĵ'">.EK"ܗfIZyZ7|W.f22P s+JCw xƏⲼ,?,p _c_8gYHžѵ0V>nE"SqOkrʢV ֩֩ \q:R)fyk(d&n@b!pNj6Wcx< T^3mm~ڋ: \β[?}[7 {ꭱ 8J *w .im1fPwrCHi._mS`ETNY<bxpe_x$ O<B@I+(@\:ΝkB[>J9ӝg gGR~ 0%Pț]_&9)BA?fvnb_.t9,TJ Ҁ7IndqAL6 ^}McZScZ=6xF1TNeCL }qY?rZ4 2" B<TźH09q/cZJ(@: NQ5Wa&t&m:)lrDGuϚa/uK֋ &dkiy)ø\ -?ӑ>`إa h!C\sǼDm~r"_Vʞ/.¥Yc?b+ 3w19P//tt\D(9bDDa8 I. :&YО鱲6c)h6y)"TI 37]: =zh(J5Rn1)Wg=^|E˄ޕZ᪫B?2=_;?mz9T)iL(΍7Pq^HB2 T[ ymXbZu Oö{3fYVFxܯ~4\d@,p\=+Z@rtq7ܷt%Y\oT/lLAdR(#K\S\\EQh۸"f'Z#.T>Ue̋4\E=S)c?DC. +9֣`b*!yYRX0jO`,᫚nbcbm3ugSʀm|'L1e,W[4Z(h='I_;ѧ_nYyendstream endobj 506 0 obj << /Filter /FlateDecode /Length 1877 >> stream xWͫ$_H&;]}? LFG 3USϮ^f YDT& ܊ wB! DOȹuު=Ə<]u9w>1NH_,"#HgYg체`C!&*1L"B OG@YDS it &S`u[ah52FcV#f`:Ub>p$A?/@k`8&zz]5&(a 71%D&)j/ X&,at(߆yUE^yJ|q-3΁Hƹ;^LI"u, '6˜ΰ|@YtedKko1pa-͞2|L4 8,&ŧbέًN.Y/m AÙTl*fOGwT<~zٿ/>}y#Щ݇ykw_<~?|^?כ>_UutPK8.&L,c"D^ީ%'8- *T7fK-:FDPx-Jrh@h"`yI5b&k # H8Oi"$q ɔCW&!^rRi{T/}EI4 zvu>Q#;-Pb "׷*+Eo7_2<QFxxc|sxkb㤖ajHPZRV/ !#^':2^h1iˆ@hIGX$N 0o0@ G +P?@-0L,D┲DY@iWT4h`%3]mA5) 6#* kds2 1^iOknaT 0,tap=h[v;skZcС#Ţ.]X-Bȴ3u_g =JTEPR)Bv6E*H1?͟>嚚@cP~t7i2м-ܲdh s{aJ((g:\[|MT)@g[vֈU]ːՓJ[<B5FEYja뵎) 9}m4 nuP"tfe^N8 VNO4&X9y8BչkLtϟKm=gXL p6+Wv[ 1NѠ*׵ejD8m3H{"> 3B7"Դf(fkuenkydTݍl]PK?Z?9$P&cUG`Tb.v~308!$'GٲbRh{S\/'Wd¸g%tٶL3X4mhd}̒ei" /͋lSAU""l+jQs&7J-2;MaP_xlɉ `hqq#+MK8>x>34e~e *!zq{[nujPP*XlopYruX[㬮;y Soֶ]Tn/)\BV6hydtw8ջz\ڶ>pbrl=Gd-"Lk"R̮$𒄘Za;/-@N؊Q,8Gz(#CƹqQG8"H@@OЯ=nE3E@Iخ1Ҵ&pr>tQ|\t쵅0TB Zendstream endobj 507 0 obj << /Filter /FlateDecode /Length 162 >> stream x]O10 uA,tЪj8(NߗNN>zK X&었EUq0N:txj w=|6-4R> stream xcd`ab`dd74 JM/I, f!CL<<,o$={ #cxz~s~AeQfzF.THTpSJL//THKQS/ f*h)$f$))F(+k꡻ /,/I-KI+)6d```Tg`b`bdd ˾*p?nv.WVUUY!> stream AdobedC    %,'..+'+*17F;14B4*+=S>BHJNON/;V\UL[FMNKC $$K2+2KKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKK" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?ƫd6.G@D;C*NT-ӞAW**>Trzo@D'P8}O#zW)he< p;6/M1s;Tp_ݑ}Žx;`|~1=9HRV]v}r8o]Ԓ)v6QX~Rsp"eЉg*uS4Mӟ6ߡbHP 012ܟNt9!GrJn(ۏq]9Ju3d?^?vc|z8{ж>u 0AIpQ>lxph _r B1ی ǃ2A2L|m^FPv3K$*Kn#!1rr=PD p"-߉~܏_z\4S2L j7>tֺ'm:9jH9m&G͐1>d5(n(B) =PQN~>#{GniSMʌ<9M;*֨WoƤg o8xScpX~lc#֬E8![d9D)6|>W`n1^5DY`P ?J~Wn\{T^o/Cӷ;C*$m'| QxMt\{vSwz\^jwyplTݷB>*SWxxͅ8$_j[1ʶ|,_7gս~_O7 |J#=qqSl f)z!Uv8 =~~R2q!aɳ?1.?1e߳w3F:/LsӶ;PC|cc\,GU23%U9NNEI<˿R?SВ럧|qre:v秨89.b8Ɍ&񵌜nV\ztZY< ~nqq9pM9`7b{yӾ17q"FV#I7ɐѐ@vӢ+ZG?2m4.Fr=0sU݄`c8<~>)+bąi Gǝ v.j)"Q 8Yш(dGLdszfi6&D]޿w>yg6Q.?}~I^;Ta%IcvqNbwCpŔ!GGC=SOIIgr:[Ps$paelF݆RTRN. {y=3cJ'@ČHg8OIg3c;^ϽE;@UyFA9 A.񰢩}1 ǵ7+o{u%v)?wN"0$@Y&mGCq>⤖kcrD~nwtslgQ@ e)ʦ2(8 O{~ΛB$`=*.^8 X`r>N{LE]#nc!Tܭzjl]H|21<¤7r{_#To6$¼rzRFbs ۆxc.U` 1:Nƚg)A }r]80ueٌcǵ=eݩ1~yӶ>nUY}U[?X{};\HVmw+> e[tu+1\mPLHJA:ojVlO|M?O,P;X|'AG?A֫**F$ق[xL4gXv.N cqqh㢸DBcnG#\~za!\&H zq_;DTym?tq:vlSK% 5qw=g,D&̆ ǧ?EV>Sx!?n~RC.6 XN;LK!OܬqUCi FP*;`gO#LP'`6n pyzd77/lTms2R3weDj=2=S={o839Ӿ=854mr>JY./>we(=}22rZ` #*qGnjHpZU-wz9\cndxd\/սNj[*&?3zݴǧz<8B0 ^Yڠq;QXLn|nF,e}v|Q0H0'v@3}(xoި;~}c2( !yҫ\ݼ&<5wm'_U'`28$('?GLqR Go=ɗocfA$ufY$9nyjd<dozH`wm:יM)8|20U8 d `dvx0d, L?/M[_晢߿y=*Yl wF <qp@ 2mܻO;jwmvD ?^E%/nv{x}8ゔЇͷd=ǾsH у/%d/v}1OzEIh%P$'OS.vw?~ӎyLEX;d2:So3hك3P$w eV܉l_/*3#SCR噿w32n_yw9Bѻߦ1aApr p#ӚlSH̤;^xY)~=0<8jy#Y=6c>5G_,BQܨ2e6Q3cqR]n0}bW9"6}nom2˝IG?ӊcB}_i?Fvu(!-~z mj V>\{w yag;pui4L@6cwQ;Jq+^Kgh3>_z_)`_8gNV+jec sf2JTp۸SԢ7|,d>F0n-n<ۻlN3cze'cU7.W??>~n'ڡm|9ǭ0B2YQg_sӾ{S4[X/g~&eB @PztaT$<<^Љm#'Q?=(:Α|"\}yqVY`%ޑ,a9n03A)|d&/c-ӂ6?{$)5" -'zhgQf`sGV t2GiJ3dqҧ20hxi ^1ک#0ud>RORP68냻;RGm6);O}O׽Wi,>Z!UL| L'|dӽF9ANx|HvwܿM8yq6̫O҄DffWIat7~-\Wlv?/j@[;I.#"%ewW b$2r93MoFi-1:c(GZAkyJlmz]HA+6' ?_I ȏ/~__O,eh}Q>aӣ'9+ d#*X>ci}}?;ӐU;H LL8n~M>3qtP8n6sC"1F7q|w?UFcg(N{(OD`UP:Ǫq-ٕaʹl ˎkOSv{H&I E#_[=z2`m.0Xez=hC$ a^d+-L1_4R`]̤ HFIqq:s xJY>P3ǧr9} lݙ:78[lrXa)$oTRYn~t m-YK>`F>O1v zj2W|۸ @Zm#sK4D\:ˌ~=ۜ `oo$0^9cs׽#BfSB\f0Ӯ6 nB}5 J [#1pǧ8ܕiF}='. p&|Lcg8Itr7k%bOOn=).쪱TQʑ{dut<0K;|Ϳ}n9oS})yn1ĝ[ipr{ඁԉLB4Ȇ=|wmӎ* kA!>n8Pq$ t?1c:J FD8fs~UXEeuL@Xʎ~a2:F\QUr c:Q {y-I!]~^vp:Zn[cy"Fl~@Ogqޤb3F;p?߷9I&HǹT9ʼnRoUlIwuG#a2lh'c;N8N1 Fie q+MBx`F[眏~9=0a|2CW<T#p3<Ҹ-Bp-N>ST*G o\`sן#c ۜ~\#"ٺ*`lglR$B3Hv!LӊظHH"]?/ʊ)݊[`HIx$9\zOk%ywpA (/U4QR$9e h2?֫s['1۱ϿOʊ(-]e>n‘lBY1,~Jte9NI }u L4xoIo)>R0wt(L1^o\|\pQ{zTH8k1Rz|J(h GIVI-%^41 ?׭Qp 4* 8ڼs~Tҫ I `kc_EaaA;o݁s=?*3mendstream endobj 510 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /Filter /DCTDecode /Height 150 /Subtype /Image /Width 150 /Length 2522 >> stream AdobedC    %,'..+'+*17F;14B4*+=S>BHJNON/;V\UL[FMNKC $$K2+2KKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKK" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ?1ow>6vҢ'?/{sbbz_SL'O=i TXw,?:Ua5\vX.lYc8^uT,WPW,6DH5%C(18cJbTaԊ5vKa\ѹz4},fNqߥ_OZ+yk?qQ:Ob6?BdJ{'ORn_(o¢'8SHɲpO?DS>J͛<߾;U<~BH?ή%ж$AAeQQJ)T{S׭FERʦnc/Et/EdfE/iɦ8MhmSqYK%mzSA-?J5~@bqfT{!d+/qoΥR4>~xn)ᾕcH^?׊p|fҜSȇsQo_HҳT![SGxdsڦPsv;wV|mE\&jfi.")p!S ~?zPnj_A=JHIScçAbstLl8;֛J<6:cFOZT4]Q98rҕXVRJj([6檫CC4#?-EebN9R晷ڤdxǽIړm1ޚGKژWڀ2d~3Ҩ2v+J= @~'`l1?bLCrIir7悄=a99'bA};i?0 /9?HY=@ڥ楌9ǎ*hCE"mZ)V,i&EHf+␊v)1LޘGIiʿ~=9+|=+=tCc6Bš㞘Ԍ?٦89qZP? N~zbNF)~QjF}p1OKz>ԝ6~_=8Jc­2H8);/'1@ͳqPpyPq}=?UN M/ҧ atںQOG+}6T_ғU\Di>Y2sڋ|³kZ3 h]zʬnMIh%B)*C݇>irӵ4c<;iV*88QtUvL1?*3p8cޙ [~6GQP'vɣKۭG(t};RyJ(pҘڊ(vAQEtGbS$gQEhBъg3ڊ*4hDndڊ*C"*,JĹ%gu(ɻendstream endobj 511 0 obj << /Filter /FlateDecode /Length 1663 >> stream xX͋E?Q̓PH?B|C$Qw7$bA_Z(`&QkÓðO4FKngGR-5(5՞Sl dgWK=|TdOǓQ1"&9r>=ScjRk*Ѧ̝0T=kJJ:> $ m0XERͷ-JsF3  ֎d   V&.d3 \Ct{@eVD:X%o~2=o/su7|'.|6ٯ|=O}G}O|Ƿ}g~s?wo|^*{S{=_dGNDɆ:Xe4SVt-eb `HJbiZ'GLHbIn8UxĄ fb9UXJC  x Ng*4@(bQ\VEM-UBuTbH*ba !(xt 7tH;3\ᅶ:$p aL!T]ϕ=S}H]ඊN0>D'҇'8ħФBҠlx*e  ::x[&zNۺB9@u]ם]Jj Vu UXj6 rL b oj2#BDYJزi>JF(JK MZ;j] Riy!#T2+E:"$ D&,vX+"!btj)Ic.`tj .oJjXQ γZC #] ]Z+ !Zgz/mj]p_sv~)]u$8H/Hk7НVYn&Mm `o!nu}xDh0f.&VL:Y a>X+!9bbtX-XM:O VL"9bHb-{+v&y &c˼e>Fu7XSU7/<ar,TRPxb"ީjqsKq0츥݋&3! BVT+a$W/R|x2"o!^./qSMO:5RB_i*endstream endobj 512 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /Filter /DCTDecode /Height 150 /Subtype /Image /Width 150 /Length 2835 >> stream AdobedC    %,'..+'+*17F;14B4*+=S>BHJNON/;V\UL[FMNKC $$K2+2KKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKK" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ? wlJ\@+zT>??M]*CqIZMP}֏ҳ=^ߵ1XmU/Զ_9;z4;w?^+'NYzwskIܴ5?h7cazS <}֜?0?Z,EWO6`yIz\>SKri?u>T9POqZkcJhA,]J.%CܴQE!\urCAR[~ao?h/JkAzW<4AAP:S hN_(%QHg|z\Cr}*o,=gB6t{}+041ެ9n=)N֜̋%D׷Ҭw')i.m wAoJz{ `r=D6)KO?W~=W]}}HKL'ο=G=JKfy_֞-=W̅b0UW\1kH@CWS."X4WBz*HJmϨ)dm2Rh?kEzV^ gq4֦ؒT~jrE8_*6Aie84X T~r)Yw\i ?Oz7Iznax{?;v1O9o߷O3߷׭R-oZ֊lV2'_|j^.mwQz6KH&K߷קI^^2?ZgZ|,zi!~ß=UI|wqFIӏoLm? 7J[rz3QVFScZy1.{K\v?ҳI khI]//e]u+q"$曧)E _ZujhirDf__ZE.DIq~ N?ޛ8?/^aW=[L= nOZakA}ڮݾoCv_ZH^:ACր$^-_Zpz&SuN w?ʤsu)j#3W}/= MZsRނ'֍!uF`q)~Qt]QRy_~R :M שv|t޾ ty=Nץ0_󚔯-ӧ0U?/zOZOU:t{ա͇5"4OEN{~t0qޯ_Zt1)%Sl~u {ڴVLqPg#xqJS`: Yq8 ׷FᄑjePS`͹ H._=7:!H@4M۹?hr(TwZK0zE-ҡ-ץFq֊+DIc5]^*Ѕ|o=jEǿZ(ܽz_𢊨ǽC>6{QEZ$"l[w~52 m#U/]@ETv%0uǥQZendstream endobj 513 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceGray /DecodeParms << /Columns 150 /Predictor 15 >> /Filter /FlateDecode /Height 150 /Subtype /Image /Width 150 /Length 484 >> stream xѲ0 D?*()zLӐ8!Fc:jRV3Ռf,ec00000000000000X!'ZƒNWV?䖱 Z cn;8888888Xs7dg_DђN1S{5F$5X9xX0ZܓB XN 1Z5당~)07bFFf`]%,VZ.ĺ4Y(_CeeC}*D!ҰkoCpp-R4KQ⣕SSh ,fկ'`A7Z X6˯3A|ŨW톅yToD X`ѮЦ5pڝ뇢kXw!$ZoT'o hm XoT])%mendstream endobj 514 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /Filter /DCTDecode /Height 150 /SMask 513 0 R /Subtype /Image /Width 150 /Length 3290 >> stream AdobedC    %,'..+'+*17F;14B4*+=S>BHJNON/;V\UL[FMNKC $$K2+2KKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKK" }!1AQa"q2#BR$3br %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz w!1AQaq"2B #3Rbr $4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz ? wlJ\@+zT>??M]*CqIZMP}֏ҳ={x?kj+Y $v4W C?cN{5jv/}k_<+os=+ViٕQE((⓯j|{n~}M{Ir=7JЂXԕ]Jh(C TLQT|*;/٫SljϭhQEdPQEQE^_'~%90G'ҭ@^]G!M++mPCsPH;>8Nqxy9dFH`V N§hz}k^fEwQ{R\!(0L\5KT"O3ڏ3ڙEAqgYG?SjZCL%~^޵RRұId>1Wbfʼf(Ƞ((8IJ] ][l 8JaHt=C瓧bUHLʗJ{Vūlt9 gO֪rOmiYRl+ŻgB_J?iarESOBEI)M҅1mJMg?zwkЍyv gE= N]7d9b}}7Q\&ZW1WOg>Ƽhue_*=<7_T{)dtTW= $Dt%6hR.{T.HQTȃEWuQ@S9h7=F=?}Q@cޒzy%79#ߥlVU[ +y 䃏ߟjn&dޘ1˙y+]a ܷr:'ӓԓFyxOdsqSYW6Ej3襍$GO98[ upqJqZڬd,$0=t M4֤԰# 5wDfHhiѧ3sxT]aTW_ǷEᝁEPEPEPYڟ-o'EM!NzqJЬ'ԮeR|cp:tTm}D YܥLa5%ȿIG,0w\i*DA ;($$Ǹu-1mTP iZdSc<xr\snŧ> /Filter /FlateDecode /Height 1 /Subtype /Image /Width 100 /Length 18 >> stream xc@,`$Z%:dendstream endobj 516 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /DecodeParms << /Colors 3 /Columns 100 /Predictor 15 >> /Filter /FlateDecode /Height 1 /SMask 515 0 R /Subtype /Image /Width 100 /Length 75 >> stream xcd_ H2` 6HD2H4A I v{2 Րendstream endobj 517 0 obj << /Filter /FlateDecode /Length 3828 >> stream x[[ܶ~4@4g*^EHh$[xVF;q}υHJ ?9$ΕF\/;\׻}l|+"nL\*%W7bdč8iaպ g]u:u+|5^;WVk>FԾi$R,'T*ۛcBudmF #7~6R}מc|u؞M*z7nN~}3WfOVtYg,)i&|;Iٴm-TF_QO[DFvbti#Eʸ;tNPfS ]]ݍz z<(`Ax 6}[܌h6|>h`gSXI8T` [ o}~ wSb)VM HT쵒0"~x -Hjt7ɬ}jC(?\}uN\: tDrFi/Z&^VU{ڬZN3/+`׈2m ed{q'<\bAMPQAQ زǡ4qg\sdA/``6SXn(b,Iag[i$kH$/m8k6Ӟ 7Ɗtot`s0^Y*K0Taq[bV)2~"arPP/ZJKbI˗ i* =s$]8o|V`u2!!1 ]S i9gXuC W0NsQe}3MrvSրiu3ěVWw-m2jl&9_v1c04$ϡW~ZJsV6~d>xKkA! KDEl!:t Glj&Hk mw.fI?CVsE)^bƕP'A<*<͢ a[˔깸WqY$͙B =Gs/KB<|A}:Su<7qޯ˃1bx*b7a;P9̢ОW-%z(6ߎ5}j]|/Ŀiз-%И6ʇ|۫ahfz4ӣ *tDzN᦭4g1}v m?tw=gGH*Ygniu]2YHOBMh k! GrY=3X}y]ve 3xԵ0~_ty▢+#1+[1m^LWFR@C J)"xuQ#z&djU4^b^JOr曌yqRKt;tfe8ǖ-(2k'y=ʅk SqjEŕ)"[MRdp9gfNBּ+M0F3?% IZ+;2KLsk9{srOJ篮endstream endobj 518 0 obj << /Type /XRef /Length 391 /Filter /FlateDecode /DecodeParms << /Columns 5 /Predictor 12 >> /W [ 1 3 1 ] /Info 3 0 R /Root 2 0 R /Size 519 /ID [<369c2ff77f59529976e2fb0c57e974d9>] >> stream x햽/Ca{QE)mlEHD,MAb-a0`P!|DbP`_V\}~/v<6ٖ1~il5,iD{3wu}ҏ œuS M?y|阞dWʥL ߈C1gA $iً /ł1z.#oC~ZlO̘E/Kx/t~MIm u8AgE 3x+c}a{ǩ#8 :lIߘ,~5;̷O~X fuq m\ So՜3-5y'&}Mplg>3}\@ +@T. \v.?>n yYܰdM endstream endobj startxref 337342 %%EOF seriation/inst/doc/seriation.Rnw0000644000176200001440000024054614456107274016503 0ustar liggesusers\documentclass[nojss]{jss} \usepackage[english]{babel} %\documentclass[fleqn, a4paper]{article} %\usepackage{a4wide} %\usepackage[round,longnamesfirst]{natbib} %\usepackage{graphicx,keyval,thumbpdf,url} %\usepackage{hyperref} %\usepackage{Sweave} \SweaveOpts{strip.white=true} \AtBeginDocument{\setkeys{Gin}{width=0.6\textwidth}} \usepackage[utf8]{inputenc} %% end of declarations %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \usepackage{amsmath} \usepackage{amsfonts} %\newcommand{\strong}[1]{{\normalfont\fontseries{b}\selectfont #1}} \newcommand{\class}[1]{\mbox{\textsf{#1}}} \newcommand{\func}[1]{\mbox{\texttt{#1()}}} %\newcommand{\code}[1]{\mbox{\texttt{#1}}} %\newcommand{\pkg}[1]{\strong{#1}} \newcommand{\samp}[1]{`\mbox{\texttt{#1}}'} %\newcommand{\proglang}[1]{\textsf{#1}} \newcommand{\set}[1]{\mathcal{#1}} \newcommand{\sQuote}[1]{`{#1}'} \newcommand{\dQuote}[1]{``{#1}''} \newcommand\R{{\mathbb{R}}} \DeclareMathOperator*{\argmin}{argmin} \DeclareMathOperator*{\argmax}{argmax} %% almost as usual \author{Michael Hahsler\\Southern Methodist University \And Kurt Hornik\\Wirtschaftsuniversit\"at Wien \AND Christian Buchta\\Wirtschaftsuniversit\"at Wien} \title{Getting Things in Order:\\ An Introduction to the \proglang{R}~Package~\pkg{seriation}} %% for pretty printing and a nice hypersummary also set: \Plainauthor{Michael Hahsler, Kurt Hornik, Christian Buchta} %% comma-separated \Plaintitle{Getting Things in Order: An Introduction to the R Package seriation} %% without formatting \Shorttitle{Getting Things in Order} %% a short title (if necessary) %% an abstract and keywords \Abstract{Seriation, i.e., finding a suitable linear order for a set of objects given data and a loss or merit function, is a basic problem in data analysis. Caused by the problem's combinatorial nature, it is hard to solve for all but very small sets. Nevertheless, both exact solution methods and heuristics are available. In this paper we present the package~\pkg{seriation} which provides an infrastructure for seriation with \proglang{R}. The infrastructure comprises data structures to represent linear orders as permutation vectors, a wide array of seriation methods using a consistent interface, a method to calculate the value of various loss and merit functions, and several visualization techniques which build on seriation. To illustrate how easily the package can be applied for a variety of applications, a comprehensive collection of examples is presented.} \Keywords{combinatorial data analysis, seriation, permutation, \proglang{R}} \Plainkeywords{combinatorial data analysis, seriation, permutation, R} %% without formatting \Address{ Michael Hahsler\\ Engineering Management, Information, and Systems\\ Lyle School of Engineering\\ Southern Methodist University\\ P.O. Box 750123 \\ Dallas, TX 75275-0123\\ E-mail: \email{mhahsler@lyle.smu.edu}\\ URL: \url{http://lyle.smu.edu/~mhahsler} Kurt Hornik\\ Department f\"ur Statistik \& Mathematik\\ Wirtschaftsuniversit\"at Wien\\ 1090 Wien, Austria\\ E-mail: \email{kurt.hornik@wu.ac.at}\\ URL: \url{http://statmath.wu.ac.at/~hornik/} Christian Buchta\\ Department f\"ur Welthandel\\ Wirtschaftsuniversit\"at Wien\\ 1090 Wien, Austria\\ E-mail: \email{christian.buchta@wu.ac.at}\\ URL: \url{http://www.wu.ac.at/itf/institute/staff/buchta} } \hyphenation{Brusco} \sloppy %% \VignetteIndexEntry{An Introduction to the R package seriation} \begin{document} %\title{Getting Things in Order: An introduction to the %R~package~\pkg{seriation}} %\author{Michael Hahsler, Kurt Hornik and Christian Buchta} \maketitle %\abstract{Seriation, i.e., finding a suitable linear order for a set of % objects given data and a loss or merit function, is a basic problem in % data analysis. Caused by the problem's combinatorial nature, it is % hard to solve for all but very small sets. Nevertheless, both exact % solution methods and heuristics are available. In this paper we % present the package~\pkg{seriation} which provides an infrastructure % for seriation with \proglang{R}. The infrastructure comprises data % structures to represent linear orders as permutation vectors, a wide % array of seriation methods using a consistent interface, a method to % calculate the value of various loss and merit functions, and several % visualization techniques which build on seriation. To illustrate how % easily the package can be applied for a variety of applications, a % comprehensive collection of examples is presented.} % <>= options(scipen=3, digits=4) ### for sampling set.seed(1234) @ \section{Introduction} A basic problem in data analysis, called \emph{seriation} or sometimes \emph{sequencing}, is to arrange all objects in a set in a linear order given available data and some loss or merit function in order to reveal structural information. Together with cluster analysis and variable selection, seriation is an important problem in the field of \emph{combinatorial data analysis}~\citep{seriation:Arabie:1996}. Solving problems in combinatorial data analysis requires the solution of discrete optimization problems which, in the most general case, involves evaluating all feasible solutions. Due to the combinatorial nature, the number of possible solutions grows with problem size (number of objects, $n$) by the order~$O(n!)$. This makes a brute-force enumerative approach infeasible for all but very small problems. To solve larger problems (currently with up to 40 objects), partial enumeration methods can be used. For example, \cite{seriation:Hubert:2001} propose dynamic programming and \cite{seriation:Brusco:2005} use a branch-and-bound strategy. For even larger problems only heuristics can be employed. It has to be noted that seriation has a rich history in archaeology. \cite{seriation:Petrie:1899} was the first to use seriation as a formal method. He applied it to find a chronological order for graves discovered in the Nile area given objects found there. He used a cross-tabulation of grave sites and objects and rearranged the table using row and column permutations till all large values were close to the diagonal. In the rearranged table graves with similar objects are closer to each other. Together with the assumption that different objects continuously come into and go out of fashion, the order of graves in the rearranged table suggests a chronological order. Initially, the rearrangement of rows and columns of this contingency table was done manually and the adequacy was only judged subjectively by the researcher. Later, \cite{seriation:Robinson:1951}, \cite{seriation:Kendall:1971} and others proposed measures of agreement between rows to quantify optimality of the resulting table. A comprehensive description of the development of seriation in archeology is presented by \cite{seriation:Ihm:2005}. Techniques related to seriation are also popular in several other fields. Especially in ecology scaling techniques are used under the name \emph{ordination}. For these applications several \proglang{R} packages already exist (e.g., \pkg{ade4}~\citep{seriation:Chessel:2007,seriation:Dray:2007} and \pkg{vegan}~\citep{seriation:Oksanen:2007}). This paper describes the new package \pkg{seriation} which differs from existing packages in the following ways: \begin{itemize} \item \pkg{seriation} provides a flexible infrastructure for seriation; \item \pkg{seriation} focuses on seriation as a combinatorial optimization problem. \end{itemize} This paper starts with a formal introduction of the seriation problem as a combinatorial optimization problem in Section~\ref{sec:seriation}. In Section~\ref{sec:methods} we give an overview of seriation methods. In Section~\ref{sec:infrastructure} we present the infrastructure provided by the package~\pkg{seriation}. Several examples and applications for seriation are given in Section~\ref{sec:example}. Section~\ref{sec:conclusion} concludes. A previous version of this manuscript was published in the \emph{Journal of Statistical Software} \citep{seriation:Hahsler+Hornik:2008}. \section{Seriation as a combinatorial optimization problem} \label{sec:seriation} To seriate a set of $n$ objects $\{O_1,\dots,O_n\}$ one typically starts with an $n \times n$ symmetric dissimilarity matrix~$\mathbf{D} = (d_{ij})$ where $d_{ij}$ for $1 \le i,j \le n$ represents the dissimilarity between objects $O_i$ and $O_j$, and $d_{ii} = 0$ for all~$i$. We define a permutation function $\Psi$ as a function which reorders the objects in $\mathbf{D}$ by simultaneously permuting rows and columns. The seriation problem is to find a permutation function $\Psi^*$ %$\{1,\dots,n\} \rightarrow \{1,\dots,n\}$, i.e. a %bijection that maps the set of indices of the objects (and equally of rows and %columns of $\mathbf{D}$) onto itself, which optimizes the value of a given loss function~$L$ or merit function~$M$. This results in the optimization problems \begin{equation} \Psi^* = \argmin_\Psi L(\Psi(\mathbf{D})) \quad \text{or} \quad \Psi^* = \argmax_\Psi M(\Psi(\mathbf{D})), \end{equation} respectively. %This is clearly a hard discrete optimization problem since the number of %possible permutations is $n!$ which makes an exhaustive %search for sets with a medium to large number of objects infeasible. %Partial enumeration methods and heuristics can be used. Such methods are %presented in Section~\ref{sec:methods}. %But first, we review commonly used loss functions in the following section. %\marginpar{two-mode data missing} A symmetric dissimilarity matrix is known as \emph{two-way one-mode} data since it has columns and rows (two-way) but only represents one set of objects (one-mode). Seriation is also possible for two-way two-mode data which are represented by a general nonnegative matrix. In such data columns and rows represent two sets of objects which are reordered simultaneously. For loss/merit functions for two-way two-mode data the optimal order of columns can depend of the order of rows and vice versa or it can be independent allowing for breaking the optimization down into two separate problems, one for the columns and one for the rows. Another way to deal with the seriation for two-way two-mode data is to calculate two dissimilarity matrices, one for each mode, and then solve two seriation problems for two-way one-mode data. Furthermore, seriation can be generalized to $k$-way $k$-mode data in the form of a $k$-dimensional array by defining suitable loss/merit functions for such data or by breaking the problem down into several lower dimensional independent problems. To assess the complexity of seriation of $k$-way $k$-mode data, let us assume the data is a $k$-dimensional array with the dimensions containing $n_1, n_2, \ldots, n_k$ objects. If the loss/merit function allows for separating the problem into $k$ independent problems, the problem size is just the sum of the individual problems. By using complete enumeration the size is $O(\sum_{i=1}^k{n_i!})$. If the problem is not separable and the optimal seriation of each dimension depends on the order of the objects of the other dimensions, the problem size is $O((\sum_{i=1}^k{n_i})!)$. For example for $k=5$ and all dimensions containing 5 objects, the search space for separable dimensions is only 600 while without separability it is larger than $10^{25}$ clearly too big to be solvable in reasonable time. This shows that for data with even only a few dimensions and a few objects each, finding the optimal solution is infeasible and loss/merit functions which allow for separating the problem are highly desirable. In the following subsections, we review some commonly employed loss/merit functions. Most functions are used for two-way one-mode data but the measure of effectiveness and stress can be also used for two-way two-mode data. For the implementation of various loss or merit measures see function~\func{criterion} in Section~\ref{sec:infrastructure}. %\section{Loss functions} %\label{sec:criteria} %In the literature several loss functions are suggested. %We review the most commonly used functions. \subsection{Column/row gradient measures} A symmetric dissimilarity matrix where the values in all rows and columns only increase when moving away from the main diagonal is called a perfect \emph{anti-Robinson matrix} after the statistician \cite{seriation:Robinson:1951}. Formally, an $n \times n$ dissimilarity matrix $\mathbf{D}$ is in anti-Robinson form if and only if the following two gradient conditions hold~\citep{seriation:Hubert:2001}: \begin{align} \text{within rows:} & \quad d_{ik} \le d_{ij} \quad \text{for} \quad 1 \le i < k < j \le n; \\ \text{within columns:} & \quad d_{kj} \le d_{ij} \quad \text{for} \quad 1 \le i < k < j \le n. \end{align} In an anti-Robinson matrix the smallest dissimilarity values appear close to the main diagonal, therefore, the closer objects are together in the order of the matrix, the higher their similarity. This provides a natural objective for seriation. It has to be noted that $\mathbf{D}$ can be brought into a perfect anti-Robinson form by row and column permutation whenever $\mathbf{D}$ is an ultrametric or $\mathbf{D}$ has an exact Euclidean representation in a single dimension~\citep{seriation:Hubert:2001}. However, for most data only an approximation to the anti-Robinson form is possible. A suitable merit measure which quantifies the divergence of a matrix from the anti-Robinson form was given by \cite{seriation:Hubert:2001} as \begin{equation} M(\mathbf{D}) = \sum_{i y. \end{cases} \end{equation} It results in the raw number of triples satisfying the gradient constraints minus triples which violate the constraints. The second function is defined as: \begin{equation} f(z,y) = |y-z|\mathrm{sign}(y-z) = y-z \end{equation} It weighs each satisfaction or violation by its magnitude given by the absolute difference between the values. \subsection{Anti-Robinson events} An even simpler loss function can be created in the same way as the gradient measures above by concentrating on violations only. \begin{equation} L(\mathbf{D}) = \sum_{i y \quad \text{and} \\ 0 \quad \text{otherwise.} \end{cases} \end{equation} $I(\cdot)$ is an indicator function returning $1$ only for violations. \cite{seriation:Chen:2002} presented a formulation for an equivalent loss function and called the violations \emph{anti-Robinson events}. \cite{seriation:Chen:2002} also introduced a weighted versions of the loss function resulting in \begin{equation} f(z, y) = |y-z|I(z, y) \end{equation} using the absolute deviations as weights. \subsection{Hamiltonian path length} The dissimilarity matrix $\mathbf{D}$ can be represented as a finite weighted graph $G = (\Omega,E)$ where the set of objects~$\Omega$ constitute the vertices and each edge~$e_{ij} \in E$ between the objects $O_i, O_j \in \Omega$ has a weight~$w_{ij}$ associated which represents the dissimilarity~$d_{ij}$. Such a graph can be used for seriation~\citep[see, e.g.,][]{seriation:Hubert:1974,seriation:Caraux:2005}. An order~$\Psi$ of the objects can be seen as a path through the graph where each node is visited exactly once, i.e., a Hamiltonian path. Minimizing the Hamiltonian path length results in a seriation optimal with respect to dissimilarities between neighboring objects. The loss function based on the Hamiltonian path length is: \begin{equation} L(\mathbf{D}) = \sum_{i=1}^{n-1} d_{i,i+1}. \end{equation} Note that the length of the Hamiltonian path is equal to the value of the \emph{minimal span loss function} \citep[as used by][]{seriation:Chen:2002}, and both notions are related to the \emph{traveling salesperson problem}~\citep{seriation:Gutin:2002}. \subsection{Inertia criterion} Another way to look at the seriation problem is not to focus on placing small dissimilarity values close to the diagonal, but to push large values away from it. A function to quantify this is the moment of inertia of dissimilarity values around the diagonal \citep{seriation:Caraux:2005} defined as \begin{equation} M(\mathbf{D}) = \sum_{i=1}^n \sum_{j=1}^n d_{ij}|i-j|^2. \end{equation} $|i-j|^2$ is used as a measure for the distance to the diagonal and $d_{ij}$ gives the weight. This is a merit function since the sum increases when higher dissimilarity values are placed farther away from the diagonal. \subsection{Least squares criterion} Another natural loss function for seriation is to quantify the deviations between the dissimilarities in $\mathbf{D}$ and the rank differences of the objects. Such deviations can be measured, e.g, by the sum of squares of deviations \citep{seriation:Caraux:2005} defined by \begin{equation} L(\mathbf{D}) = \sum_{i=1}^n \sum_{j=1}^n (d_{ij} - |i-j|)^2, \end{equation} where $|i-j|$ is the rank difference or gap between $O_i$ and $O_j$. The least squares criterion defined here is related to uni-dimensional scaling~\citep{seriation:Leeuw:2005}, where the objective is to place all $n$ objects on a straight line using a position vector~$\mathbf{z} = z_1,z_2,\ldots,z_n$ such that the dissimilarities in $\mathbf{D}$ are preserved by the relative positions in the best possible way. The optimization problem of uni-dimensional scaling is to find the position vector~$\mathbf{z^*}$ which minimizes $\sum_{i=1}^n \sum_{j=1}^n (d_{ij} - |z_i-z_j|)^2$. This is close to the seriation problem, but in addition to the ranking of the objects also takes the distances between objects on the resulting scale into account. Note that if Euclidean distance is used to calculate $\mathbf{D}$ from a data matrix~$\mathbf{X}$, using the order of the elements in $\mathbf{X}$ as they occur projected on the first principal component of $\mathbf{X}$ minimizes the loss function of uni-dimensional scaling (using squared distances). Using this order, also provides a good solution for the least square seriation criterion. \subsection{Linear Seriation Criterion} The Linear Seriation Criterion (Hubert and Schultz 1976) weights the distances with the absolute rank differences. $$L(\mathbf{D}) \sum_{i=1}^n \sum_{j=1}^n d_{ij} (-|i-j|)$$ \subsection{2-Sum Problem} The 2-Sum loss criterion \citep{seriation:Barnard:1993} multiplies the similarity between objects with the squared rank differences. $$L(\mathbf{D}) \sum_{i,j=1}^p \frac{1}{1+d_{ij}} (i-j)^2,$$ where $s_{ij} = \frac{1}{1+d_{ij}}$ represents the similarity between objects $i$ and $j$. \subsection{Measure of effectiveness} \label{sec:ME} \cite{seriation:McCormick:1972} defined the \emph{measure of effectiveness (ME)} for an $n \times m$ matrix~$\mathbf{X} = (x_{ij})$ as \begin{equation} M(\mathbf{X}) = \frac{1}{2} \sum_{i=1}^{n} \sum_{j=1}^{m} x_{ij}[x_{i,j+1}+x_{i,j-1}+ x_{i+1,j}+x_{i-1,j}] \label{equ:ME} \end{equation} with, by convention $x_{0,j}=x_{n+1,j}=x_{i,0}=x_{i,m+1}=0$. ME is maximized if each element is as closely related numerically to its four neighboring elements as possible. ME was developed for two-way two-mode data, however, ME can also be used for a symmetric matrix (one-mode data) and gets maximal only if all large values are grouped together around the main diagonal. Note that the definition in equation~(\ref{equ:ME}) can be rewritten as \begin{equation} M(\mathbf{X}) = \frac{1}{2} \sum_{i=1}^{n} \sum_{j=1}^{m} x_{ij}[x_{i,j+1}+x_{i,j-1}] + \sum_{i=1}^{n} \sum_{j=1}^{m} x_{ij}[x_{i+1,j}+x_{i-1,j}] \end{equation} showing that the contributions of column and row order to the merit function are independent. \subsection{Stress} \label{sec:stress} Stress measures the conciseness of the presentation of a matrix (two-mode data) and can be seen as a purity function which compares the values in a matrix with their neighbors. The stress measures used here are computed as the sum of squared distances of each matrix entry from its adjacent entries. \cite{seriation:Niermann:2005} defined for an $n \times m$ matrix~$\mathbf{X} = (x_{ij})$ two types of neighborhoods: \begin{itemize} \item The Moore neighborhood comprises the (at most) eight adjacent entries. The local stress measure for element~$x_{ij}$ is defined as \begin{equation} \sigma_{ij} = \sum_{k=\max(1,i-1)}^{\min(n,i+1)} \sum_{l=\max(1,j-1)}^{\min(m,j+1)} (x_{ij} - x_{kl})^2 \end{equation} \item The Neumann neighborhood comprises the (at most) four adjacent entries resulting in the local stress of $x_{ij}$ of \begin{equation} \sigma_{ij} = \sum_{k=\max(1,i-1)}^{\min(n,i+1)} (x_{ij} - x_{kj})^2 + \sum_{l=\max(1,j-1)}^{\min(m,j+1)} (x_{ij} - x_{il})^2 %(x_{ij} - x(i-1,j))^2 + (x_{ij} - x(i+1,j))^2 + %(x_{ij} - x(i,j-1))^2 + (x_{ij} - x(i,j+1))^2 \end{equation} \end{itemize} Both local stress measures can be used to construct a global measure for the whole matrix by summing over all entries which can be used as a loss function: \begin{equation} L(\mathbf{X}) = \sum_{i=1}^n \sum_{j=1}^m \sigma_{ij} \end{equation} The major difference between the Moore and the Neumann neighborhood is that for the later the contributions of row and column order to stress are independent. Stress can be also used as a loss function for symmetric proximity matrices (one-mode data). %, %since it can only be optimal, if large values are %concentrated around the main diagonal. Note also, that stress with Neumann neighborhood is related to the measure of effectiveness defined above (in Section~\ref{sec:ME}) since both measures are optimal if for each cell the cell and its four neighbors are numerically as similar as possible. \section{Seriation methods} \label{sec:methods} Solving the discrete optimization problem for seriation with most loss/merit functions is clearly very hard. The number of possible permutations for $n$ objects is $n!$ which makes an exhaustive search for sets with a medium to large number of objects infeasible. In this section, we describe some methods (partial enumeration, heuristics and other methods) which are typically used for seriation. For each method we state for which type of loss/merit functions it is suitable and whether it finds the optimum or is a heuristic. For the implementation of various seriation methods see function~\func{seriate} in Section~\ref{sec:infrastructure}. \subsection{Partial enumeration methods} Partial enumeration methods search for the exact solution of a combinatorial optimization problem. Exploiting properties of the search space, only a subset of the enormous number of possible combinations has to be evaluated. Popular partial enumeration methods which are used for seriation are \emph{dynamic programming}~\citep{seriation:Hubert:2001} and \emph{branch-and-bound}~\citep{seriation:Brusco:2005}. Dynamic programming recursively searches for the optimal solution checking and storing $2^n-1$ results. Although $2^n-1$ grows at a lower rate than $n!$ and is for $n \gg 3$ considerably smaller, the storage requirements of $2^n-1$ results still grow fast, limiting the maximal problem size severely. For example, for $n=30$ more than one billion results have to be calculated and stored, clearly a number too large for the main memory capacity of most current computers. Branch-and-bound has only very moderate storage requirements. The forward-branching procedure~\citep{seriation:Brusco:2005} starts to build partial permutations from left (first position) to right. At each step, it is checked if the permutation is valid and several fathoming tests are performed to check if the algorithm should continue with the partial permutation. The most important fathoming test is the boundary test, which checks if the partial permutation can possibly lead to a complete permutation with a better solution than the currently best one. In this way large parts of the search space can be omitted. However, in contrast to the dynamic programming approach, the reduction of search space is strongly data dependent and poorly structured data can lead to very poor performance. With branch-and-bound slightly larger problems can be solved than with dynamic programming in reasonable time. \cite{seriation:Brusco:2005} state that depending on the data, in some cases proximity matrices with 40 or more objects can be handled with current hardware. Partial enumeration methods can be used to find the exact solution independently of the loss/merit function. However, partial enumeration is limited to only relatively small problems. \subsection{Traveling salesperson problem solver} Seriation by minimizing the length of a Hamiltonian path through a graph is equal to solving a traveling salesperson problem. The traveling salesperson or salesman problem (TSP) is a well known and well researched combinatorial optimization problem~\citep[see, e.g.,][]{seriation:Gutin:2002}. The goal is to find the shortest tour that, starting from a given city, visits each city in a given list exactly once and then returns to the starting city. In graph theory a TSP tour is called a \emph{Hamiltonian cycle.} But for the seriation problem, we are looking for a Hamiltonian path. \cite{seriation:Garfinkel:1985} described a simple transformation of the TSP to find the shortest Hamiltonian path. An additional row and column of 0's is added (sometimes this is referred to as a \emph{dummy city}) to the original $n \times n$ dissimilarity matrix~$\mathbf{D}$. The solution of this $(n+1)$-city TSP, gives the shortest path where the city representing the added row/column cuts the cycle into a linear path. As the general seriation problem, solving the TSP is difficult. In the seriation case with $n+1$ cities, $n!$ tours have to be checked. However, despite this vast searching space, small instances can be solved efficiently using dynamic programming \citep{seriation:Held:1962} and larger instances of several hundred objects can be solved using \emph{branch-and-cut} algorithms~\citep{seriation:Padberg:1990}. For even larger instances or if running time is critical, a wide array of heuristics are available, ranging from simple nearest neighbor approaches to construct a tour~\citep{seriation:Rosenkrantz:1977} to complex heuristics like the Lin-Kernighan heuristic~\citep{seriation:Lin:1973}. A comprehensive overview of heuristics and exact methods can be found in \cite{seriation:Gutin:2002}. \subsection{Bond energy algorithm} The \emph{bond energy algorithm}~\citep[BEA;][]{seriation:McCormick:1972} is a simple heuristic to rearrange columns and rows of a matrix (two-way two-mode data) such that each entry is as closely numerically related to its four neighbors as possible. To achieve this, BEA tries to maximize the measure of effectiveness (ME) defined in Section~\ref{sec:ME}. For optimizing the ME, columns and rows can be treated separately since changing the order of rows does not influence the ME contributions of the columns and vice versa. BEA consists of the following three steps: \begin{enumerate} \item Place one randomly chosen column. \item Try to place each remaining column at each possible position left, right and between the already placed columns and calculate every time the increase in ME. Choose the column and position which gives the largest increase in ME and place the column. Repeat till all columns are placed. \item Repeat procedure with rows. \end{enumerate} This greedy algorithm works fast and only depends on the choice of the first column/row. This dependence can be reduced by repeating the procedure several times with different choices and returning the solution with the highest ME. Although \cite{seriation:McCormick:1972} use BEA also for non-binary data, \cite{seriation:Arabie:1990} argue that the measure of effectiveness only serves its intended purpose of finding an arrangement which is close to Robinson form for binary data and should therefore only be used for binary data. \cite{seriation:Lenstra:1974} notes that the optimization problem of BEA can be stated as two independent traveling salesperson problems (TSPs). For example, the row TSP for an $n \times m$ matrix~$\mathbf{X}$ consists of $n$ cities with an $n \times n$ distance matrix~$\mathbf{D}$ where the distances are \begin{displaymath} d_{ij} = -\sum_{k=1}^m x_{ik}x_{jk}. \end{displaymath} BEA is in fact a simple suboptimal TSP heuristic using this distances and instead of BEA any TSP solver can be used to obtain an order. With an exact TSP solver, the optimal solution can be found. \subsection{Hierarchical clustering} \label{sec:hierarchical_clustering} Hierarchical clustering produces a series of nested clusterings which can be visualized by a dendrogram, a tree where each internal node represents a split into subtrees and has a measure of similarity/dissimilarity attached to it. As a simple heuristic to find a linear order of objects, the order of the leaf nodes in a dendrogram structure can be used. This idea is used, e.g., by heat maps to reorder rows and columns with the aim to place more similar objects and variables closer together. %For hierarchical clustering several methods are available (e.g., %single linkage, average linkage, complete linkage, ward method) resulting in %different dendrograms. %However, The order of leaf nodes in a dendrogram is not unique. A binary (two-way splits only) dendrogram for $n$ objects has $2^{n-1}$ internal nodes and at each internal node the left and right subtree (or leaves) can be swapped resulting in $2^{n-1}$ distinct leaf orderings. To find a unique or optimal order, an additional criterion has to be defined. \cite{seriation:Gruvaeus:1972} suggest to obtain a unique order by requiring to order the leaf nodes such that at each level the objects at the edge of each cluster are adjacent to that object outside the cluster to which it is nearest. \cite{seriation:Bar-Joseph:2001} suggest to rearrange the dendrogram such that the Hamiltonian path connecting the leaves is minimized and called this the optimal leaf order. The authors also present a fast algorithm with time complexity $O(n^4)$ to solve this optimization problem. Note that this problem is related to the TSP described above, however, the given dendrogram structure significantly reduces the number of permissible permutations making the problem easier. Although hierarchical clustering solves an optimization problem different to the seriation problem discussed in this paper, hierarchical clustering still can produce useful orderings, e.g., for visualization. \subsection{Rank-two ellipse seriation} \cite{seriation:Chen:2002} proposes to generate a sequence of correlation matrices $R^1, R^2, \ldots$. $R^1$ is the correlation matrix of the original distance matrix $\mathbf{D}$ and \begin{equation} R^{n+1} = \phi R^n, \end{equation} where $\phi(\cdot)$ calculates a correlation matrix. \cite{seriation:Chen:2002} shows that the rank of the matrix $R^n$ falls with increasing $n$ and that if the sequence is continued till the first matrix in the sequence has a rank of 2, projecting all points in this matrix on its first two eigenvectors, all points will fall on an ellipse. \cite{seriation:Chen:2002} suggests to use the order of the points on this ellipse as a seriation where the ellipse can be cut at any of the two interception points (top or bottom) with the vertical axis. Although the rank-two ellipse seriation procedure does not try to solve a combinatorial optimization problem, it still provides for some cases a useful ordering. \subsection{Spectral Seriation} Spectral seriation uses a relaxation to minimize the 2-Sum Problem \citep{seriation:Barnard:1993}. Rewriting the minimization problem using a permutation vector $\pi$, its inverse, rescaling to $\mathrm{q}$ and using a Lagrangian multiplier for the constraint on the permutation yields \citep{seriation:Ding:2004} the following equivalent optimization problem: $$\mathrm{min}_\mathbf{q} \frac{\mathbf{q}^T L_\mathbf{S}\mathbf{q}}{\mathbf{q}^T\mathbf{q}}$$ where $L_\mathbf{S}$ is the Laplacian of $\mathbf{S}$. The optimal order can be recovered by the sorting order of the Fiedler vector (i.e., the second smallest eigenvector of the Laplacian of the similarity matrix). \subsection{Quadratic Assignment Problem} Both, the linear seriation criterion and the 2-Sum problem formulation can be written as a Quadratic Assignment Problem (QAP). However, the QAP is in general NP-hard. Methods include QIP, linearization, branch and bound and cutting planes as well as heuristics including Tabu search, simulated annealing, genetic algorithms, and ant systems \citep{seriation:Burkard:1998}. \section{The package infrastructure} \label{sec:infrastructure} The \pkg{seriation} package provides the data structures and some algorithms to efficiently handle seriation with \proglang{R}. As the input data for seriation \proglang{R} already provides \begin{itemize} \item for two-way one-mode data the class \code{dist}, \item for two-way two-mode data the class \code{matrix}, and \item for $k$-way $k$-mode data the class \code{array}. \end{itemize} \begin{figure}[tp] \centerline{ %\includegraphics[width=12cm]{infrastructure}} \includegraphics[width=10cm]{classes}} \caption{UML class diagram of the data structures for permutations provided by \pkg{seriation}} \label{fig:infrastructure} \end{figure} However, \proglang{R} provides no classes for representing permutation vectors. \pkg{seriation} adds the necessary data structure (using the S3 class system) as depicted in the UML class diagram \citep{seriation:Fowler:2004} in Figure~\ref{fig:infrastructure}. In this diagram classes are represented by rectangles and different symbols are used to state the type of relationship between the classes. The class \code{ser\_permutation} in Figure~\ref{fig:infrastructure} represents the permutation information for $k$-mode data (including the cases of $k=1$ and $k=2$). It consists of $k$ permutation vectors (class \code{ser\_permutation\_vector}). This relationship is represented by the solid diamond and the star above the connection between the two classes. Class \code{ser\_permutation\_vector} is defined \emph{abstract} and only its concrete implementations (classes connected with the triangle symbol) are used to store a permutation vector. This design with an abstract class was chosen to allow to use different representations for the permutation vectors. Currently, the permutation vector can be stored as a simple integer vector or as an object of class \code{hclust} (defined in package \pkg{stats}). \code{hclust} describes a hierarchical clustering tree (dendrogram) including an ordering for the tree's node leaves which provides a permutation for all objects (see Section~\ref{sec:hierarchical_clustering}). Class \code{ser\_permutation\_vector} has a constructor \func{ser\_permutation\_vector} which converts data into the correct concrete subclass of \code{ser\_permutation\_vector} and checks if it contains a proper permutation vector. For \code{ser\_permutation\_vector} the methods \func{print}, \func{length} for the length of the permutation vector, \func{get\_method} to get the method used to generate the permutation, and \func{get\_order} to access the raw (integer) permutation vector are available. To use an additional class to represent permutations as a concrete subclass of \code{ser\_permutation\_vector} only an appropriate accessor method \func{get\_order} has to be implemented for the new class. For \code{ser\_permutation} a constructor is provided which can bind $k$ \code{ser\_permutation\_vector} objects together into an object for $k$-mode data. \code{ser\_permutation} is implemented as a list of length~$k$ and each element contains a \code{ser\_permutation\_vector} object. Methods like \func{length}, accessing elements with \code{[[}, % ]] \code{[[<-}, % ]] subsetting with \code{[}, and combining with \func{c} work as expected. Also a \func{print} method is provided. Finally, direct access to the raw permutation vectors is available using \func{get\_order}. Here a second argument (which defaults to $1$) specifies the dimension (mode) for which the order vector is requested. All seriation algorithms are available via the function \func{seriate} defined as: \begin{quotation} \code{seriate(x, method = NULL, control = NULL, ...)} \end{quotation} where \code{x} is the input data, \code{method} is a string defining the seriation method to be used and \code{control} can contain a list with additional information for the algorithm. \func{seriate} returns an object of class \code{ser\_permutation} with a length conforming to the number of dimensions of~\code{x}. Typical input data are a dissimilarity matrix (class~\code{dist}; see package \pkg{stats} for more information) for one-mode two-way data, \code{matrix} for two-mode two-way data and \code{array} for $k$-mode $k$-way data. For \code{matrix} and \code{array} the additional argument \code{margin} can be used to restrict the dimensions which should be seriated (e.g., with \code{margin = 1} only the first dimension, i.e., the columns of a matrix, are seriated). %\begin{landscape} \begin{table}[tp] \centering \begin{tabular}{p{5cm}p{3cm}p{4cm}l} \hline Algorithm & \code{method} & Optimizes & Input data \\ \hline Simulated annealing & \code{"ARSA"} & Linear seriation crit.&\code{dist} \\ Branch-and-bound & \code{"BBURCG"} & Gradient measure &\code{dist} \\ Branch-and-bound & \code{"BBWRCG"} & Gradient measure (weighted)& \code{dist} \\ TSP solver & \code{"TSP"} & Hamiltonian path length& \code{dist} \\ Optimal leaf ordering & \code{"OLO"} \code{"OLO_single"} \code{"OLO_average"} \code{"OLO_complete"} & Hamiltonian path length (restricted)& \code{dist} \\ Gruvaeus and Wainer & \code{"GW"} \code{"GW_single"} \code{"GW_average"} \code{"GW_complete"} & Hamiltonian path length (restricted) & \code{dist} \\ MDS & \code{"MDS"} \code{"MDS_metric"} \code{"MDS_nonmetric"} \code{"MDS_angle"} & Least square crit.& \code{dist} \\ Spectral seriation & \code{"Spectral"} \code{"Spectral_norm"} & 2-Sum crit. & \code{dist} \\ QAP & \code{"QAP_2SUM"} & 2-Sum crit. & \code{dist} \\ & \code{"QAP_LS"} & Linear seriation crit. & \code{dist} \\ & \code{"QAP_BAR"} & Banded AR form & \code{dist} \\ & \code{"QAP_Inertia"} & Inertia crit. & \code{dist} \\ Genetic Algorithm & \code{"GA"}* & various & \code{dist} \\ DendSer & \code{"DendSer"}* & various & \code{dist} \\ Hierarchical clustering & \code{"HC"} \code{"HC_single"} \code{"HC_average"} \code{"HC_complete"} & Other& \code{dist} \\ Rank-two ellipse seriation & \code{"R2E"} & Other& \code{dist} \\ Sorting Points Into Neighborhoods & \code{"SPIN_NH"} \code{"SPIN_STS"} & Other& \code{dist} \\ Visual Assessment of (Clustering) Tendency & \code{"VAT"}& Other& \code{dist} \\ \hline Bond Energy Algorithm & \code{"BEA"} & Measure of effectiveness & \code{matrix} \\ TSP to optimize ME & \code{"BEA\_TSP"} & Measure of effectiveness& \code{matrix} \\ Principal component analysis& \code{"PCA"} \code{"PCA_angle"}& Least square crit.& \code{matrix} \\ \hline \end{tabular} \caption{Currently implemented methods for \func{seriation} (* methods need to be registered).} \label{tab:methods} \end{table} %\end{landscape} Various seriation methods were already introduced in this paper in Section~\ref{sec:methods}. In Table~\ref{tab:methods} we summarize the methods currently available in the package for seriation. The code for the simulated annealing heuristic~\citep{seriation:Brusco:2007} and the two branch-and-bound implementations~\citep{seriation:Brusco:2005} was obtained from the authors. The TSP solvers (exact solvers and a variety of heuristics) is provided by package \pkg{TSP}~\citep{seriation:Hahsler:2007, seriation:Hahsler:2007b}. For optimal leaf ordering we implemented the algorithm by~\cite{seriation:Bar-Joseph:2001}. The BEA code was kindly provided by Fionn Murtagh. For the Gruvaeus and Wainer algorithm, the implementation in package \pkg{gclus}~\citep{seriation:Hurley:2007} is used. For the rank-two ellipse seriation we implemented the algorithm by~\cite{seriation:Chen:2002}. Spectral seriation is described by~\cite{seriation:Ding:2004}. Note that some methods implemented (e.g., the rank-two ellipse seriation) do not fall within the combinatorial optimization framework of this paper and thus are not dealt with here in detail. They are included in the package since they can be useful for various applications. A detailed empirical comparison of seriation methods and criteria can be found in the study by \cite{hahsler:Hahsler2016d}. %Over time more methods will be %added to the package. To calculate the value of a loss/merit function for data and a certain permutation, the function \begin{quotation} \code{criterion(x, order = NULL, method = NULL, ...)} \end{quotation} is provided. \code{x} is the data object, \code{order} contains a suitable object of class \code{ser\_permutation} (if omitted no permutation is performed) and \code{method} specifies the type of loss/merit function. A vector of several methods can be used resulting in a named vector with the values of the requested functions. If \code{method} is omitted (\code{method = NULL}), the values for all applicable loss/merit functions are calculated and returned. We already defined different loss/merit functions for seriation in Section~\ref{sec:seriation}. In Table~\ref{tab:criteria} we indicate the loss/merit functions currently available in the package. \begin{table}[t] \centering \begin{tabular}{llll} \hline Name & \code{method} & merit/loss & Input data \\ \hline Anti-Robinson events& \code{"AR\_events"} & loss & \code{dist} \\ Anti-Robinson deviations& \code{"AR\_deviations"} & loss & \code{dist} \\ Banded Anti-Robinson& \code{"BAR"} & loss & \code{dist} \\ Gradient measure& \code{"Gradient\_raw"} & merit & \code{dist} \\ Gradient measure (weighted)& \code{"Gradient\_weighted"} & merit & \code{dist} \\ Hamiltonian path length & \code{"Path\_length"} & loss & \code{dist} \\ Inertia criterion& \code{"Inertia"} & merit & \code{dist} \\ Least squares criterion& \code{"Least\_squares"} & loss & \code{dist} \\ Linear Seriation criterion& \code{"LS"} & loss & \code{dist} \\ 2-Sum criterion& \code{"2SUM"} & loss & \code{dist} \\ \hline Measure of effectiveness& \code{"ME"} & merit & \code{matrix} \\ Stress (Moore neighborhood)& \code{"Moore\_stress"} & loss & \code{matrix} \\ Stress (Neumann neighborhood)& \code{"Neumann\_stress"} & loss & \code{matrix} \\ \hline \end{tabular} \caption{Implemented loss/merit functions in function \func{criterion}.} \label{tab:criteria} \end{table} All methods for \func{seriate} and \func{criterion} are managed by a registry mechanism which makes the seriation framework easily extensible for users. For example, a new seriation method can be registered using \func{set\_seriation\_method} and then used in the same way as the built-in methods with \func{seriate}. All available methods in the registry can be viewed using \func{list\_seriation\_methods} and \func{show\_seriation\_methods}. For criterion methods, the same interface is available by just substituting `seriation' by `criterion' in the function names. An example for how to add new methods can be found in section~\ref{sec:registering} of this paper. In addition the package offers the (generic) function \begin{quotation} \code{permute(x, order)} \end{quotation} where \code{x} is the data (a \code{dist} object, a matrix, an array, a list or a numeric vector) to be reordered and \code{order} is a \code{ser\_permutation} object of suitable length. %The permutation for %\code{dist} objects uses package \pkg{proxy}~\citep{seriation:Meyer:2007}. For visualization, the package offers several options: \begin{itemize} \item Matrix shading with \func{pimage}. In contrast to the standard \func{image} in package~\pkg{graphics}, \func{pimage} displays the matrix as is with the first element in the top left-hand corner and using a gamma-corrected gray scale. \item Different heat maps (e.g., with optimally reordered dendrograms) with \func{hmap}. \item Visualization of data matrices in the spirit of~\cite{seriation:Bertin:1981} with \func{bertinplot}. \item \emph{Dissimilarity plot}, a new visualization to judge the quality of a clustering using matrix shading and seriation with \func{dissplot}. \end{itemize} We will introduce the package usage and the visualization options in the examples in the next section. \section{Examples and applications} \label{sec:example} We start this section with a simple first session to demonstrate the basic usage of the package. Then we present and discuss several seriation applications. \subsection{A first session using seriation} In the following example, we use the well known iris data set (from \proglang{R}'s \pkg{datasets} package) which gives the measurements in centimeters of the variables sepal length and width and petal length and width, respectively, for 50 flowers from each of 3 species of the iris family (Iris setosa, versicolor and virginica). First, we load the package \pkg{seriation} and the iris data set. We remove the species classification and reorder the objects randomly since they are already sorted by species in the data set. Then we calculate the Euclidean distances between objects. <>= set.seed(1234) @ <<>>= library("seriation") data("iris") x <- as.matrix(iris[-5]) x <- x[sample(seq_len(nrow(x))),] d <- dist(x) @ To seriate the objects given the dissimilarities, we just call \func{seriate} with the default settings. <<>>= o <- seriate(d) o @ The result is an object of class \code{ser\_permutation} for one-mode data. The permutation vector length is $150$ for the $150$ objects in the iris data set and the used seriation method is \code{"ARSA"}, a simulated annealing heuristic (see~Table~\ref{tab:methods}). The actual order can be accessed using \func{get\_order}. In the following we show the first 15 elements in the permutation vector. <<>>= head(get_order(o), 15) @ To visually inspect the effect of seriation on the distance matrix, we use matrix shading with \func{pimage} (the result is shown in Figure~\ref{fig:pimage1}). <>= pimage(d, main = "Random") @ <>= pimage(d, o, main = "Reordered") @ \begin{figure} \centering \includegraphics[width=7.5cm]{seriation-pimage1} \includegraphics[width=7.5cm]{seriation-pimage1-2} \caption{Matrix shading of the distance matrix for the iris data.} \label{fig:pimage1} \end{figure} We can also compare the improvement for different loss/merit functions using \func{criterion}. <<>>= cbind(random = criterion(d), reordered = criterion(d, o)) @ Naturally, the reordered dissimilarity matrix achieves better values for all criteria. Note that the gradient measures, inertia and the measure of effectiveness are merit functions and for these measures larger values are better (use \code{show\_criterion\_methods("dist")} to find out which measures are loss and merit functions). To visually compare the original data matrix and the result of seriation, we can also use \func{pimage}. We standardize the data using scale such that the visualized value is the number of standard deviations an object differs from the variable mean. For matrices containing negative values, \code{pimage} uses automatically a divergent palette. After using \func{pimage} for the original random data matrix, we create a suitable \code{ser\_permutation} object for the original two-mode data. Since the seriation above only produced an order for the rows of the data, we add an identity permutation vector for the columns (represented by \code{NA}) to the permutations object using the combine function \func{c}. This new permutation object for $2$-mode data is used for displaying the reordered scaled data. The two plots are shown in Figure~\ref{fig:pimage2}. <>= pimage(scale(x), main = "Random", prop = FALSE) @ <>= o_2mode <- c(o, NA) pimage(scale(x), o_2mode, main = "Reordered", prop = FALSE) @ \begin{figure} \centering \includegraphics[width=7.5cm]{seriation-pimage2} \includegraphics[width=7.5cm]{seriation-pimage2-2} \caption{Matrix shading of the iris data matrix.} \label{fig:pimage2} \end{figure} \subsection{Comparing different seriation methods} To compare different seriation methods we use again the randomized iris data set and the distance matrix \code{d} from the previous example. We include in the comparison several seriation methods for dissimilarity matrices described in Section~\ref{sec:methods}. <<>>= methods <- c("TSP","R2E", "ARSA", "HC", "GW", "OLO") o <- sapply(methods, FUN = function(m) seriate(d, m)) @ <>= timing <- sapply(methods, FUN = function(m) system.time(seriate(d, m)), simplify = FALSE) @ \begin{table} \centering \begin{tabular}{lcccccc} \hline Seriation Method & \Sexpr{methods[1]}& \Sexpr{methods[2]}& \Sexpr{methods[3]}& \Sexpr{methods[4]}& \Sexpr{methods[5]}& \Sexpr{methods[6]} \\ \hline Execution time [sec] & \Sexpr{round(timing[[methods[1]]][1],4)}& \Sexpr{round(timing[[methods[2]]][1],4)}& \Sexpr{round(timing[[methods[3]]][1],4)}& \Sexpr{round(timing[[methods[4]]][1],4)}& \Sexpr{round(timing[[methods[5]]][1],4)}& \Sexpr{round(timing[[methods[6]]][1],4)}\\ \hline \end{tabular} %%% fix me: for the vignette we need something else \caption{Execution time of seriation of the iris data set for different methods.} \label{tab:timings} \end{table} Table~\ref{tab:timings} contains the execution times for running seriation with the different methods. Except for the simulated annealing method (ARSA) the seriation only takes a fraction of a second. The direction of the resulting orderings is first normalized (aligned) and then the orderings are displayed using matrix shading (see Figure~\ref{fig:pimage3}). <>= o <- ser_align(o) for(s in o) pimage(d, s, main = get_method(s), key = FALSE) @ <>= o <- ser_align(o) for(i in 1:length(o)) { pdf(file=paste("seriation-pimage_comp_", i , ".pdf", sep="")) pimage(d, o[[i]], main = get_method(o[[i]]), key = FALSE) dev.off() } @ \begin{figure} \centering \includegraphics[width=.3\linewidth]{seriation-pimage_comp_1.pdf} \includegraphics[width=.3\linewidth]{seriation-pimage_comp_2.pdf} \includegraphics[width=.3\linewidth]{seriation-pimage_comp_3.pdf}\\ \includegraphics[width=.3\linewidth]{seriation-pimage_comp_4.pdf} \includegraphics[width=.3\linewidth]{seriation-pimage_comp_5.pdf} \includegraphics[width=.3\linewidth]{seriation-pimage_comp_6.pdf} \caption{Image plot of the distance matrix for the iris data using rearrangement by different seriation methods.} \label{fig:pimage3} \end{figure} The first row of matrices in Figure~\ref{fig:pimage3} contains the orders obtained by a TSP solver the rank-two ellipse seriation by Chen and using the simulated annealing method (ARSA). The results of Chen and ARSA are very similar (except that the order is reversed). The TSP solver produces a smoother image with some lighter lines visible. The reason for these lines is that the TSP only optimizes distances locally between two neighboring objects. Therefore it is possible that in a quite homogeneous block several objects are enclosed gradually getting more different and then getting more similar again (see, e.g., the light line close to the upper left corner of the TSP image in Figure~\ref{fig:pimage3}). The second row of Figure~\ref{fig:pimage3} contains three images based on hierarchical clustering. The visual impression gets better from left (just hierarchical clustering) to right (first using the Gruvaeus Wainer heuristic and then optimal leaf ordering to rearrange the branches of the dendrogram obtained by hierarchical clustering). The most striking feature in the image for hierarchical clustering (HC in Figure~\ref{fig:pimage3}) is the distinct cross going right through the center of the plot. This indicates that several relatively dissimilar objects are caught in an otherwise homogeneous block. This effect vanishes after rearranging the dendrogram branches (see GW and OLO in Figure~\ref{fig:pimage3}). %' To investigate this effect, %' we plot the dendrogram obtained by hierarchical clustering which is used %' to order the objects and compare it to the dendrogram rearranged %' using the Gruvaeus Wainer heuristic. %' %' <>= %' plot(o[["HC"]], labels = FALSE, main = "Dendrogram HC") %' plot(o[["GW"]], labels = FALSE, main = "Dendrogram GW") %' @ %' <>= %' def.par <- par(no.readonly = TRUE) %' pdf(file="seriation-pimage3_dendrogram.pdf", width=9, height=4) %' layout(t(1:2)) %' plot(o[["HC"]], labels = FALSE, main = "Dendrogram HC") %' symbols(74.7,.5, rect = matrix(c(4, 3), ncol=2), add= TRUE, %' inches = FALSE, lwd =2) %' %' plot(o[["GW"]], labels = FALSE, main = "Dendrogram GW") %' symbols(98.7,.5, rect = matrix(c(4, 3), ncol=2), add= TRUE, %' inches = FALSE, lwd =2) %' par(def.par) %' tmp <- dev.off() %' @ %' %' \begin{figure} %' \centering %' \includegraphics[width=\linewidth, trim=0 80 0 0, clip=TRUE]{seriation-pimage3_dendrogram} %' \caption{Dendrograms for the seriation with HC and GW.} %' \label{fig:pimage3_dendrogram} %' \end{figure} %' %' Comparing the two dendrograms in Figure~\ref{fig:pimage3_dendrogram}, we see %' that the branch left from the top is almost unchanged. The branch which is %' responsible for the light cross in the shaded image is highlighted by a box. %' The Gruvaeus Wainer heuristic rotates the highlighted branch towards the right %' since the objects in it are more similar to the objects in there. Finally, we compare the values of the loss/merit functions for the different seriation methods. <<>>= crit <- sapply(o, FUN = function(x) criterion(d, x)) t(crit) @ <>= def.par <- par(no.readonly = TRUE) m <- c("Path_length", "AR_events", "Moore_stress") layout(matrix(seq_along(m), ncol=1)) #tmp <- apply(crit[m,], 1, dotchart, sub = m) tmp <- lapply(m, FUN = function(i) dotchart(crit[i,], sub = i)) par(def.par) @ \begin{figure} \centering \includegraphics[width=14cm]{seriation-crit1} \caption{Comparison of different methods and seriation criteria} \label{fig:crit1} \end{figure} For easier comparison, Figure~\ref{fig:crit1} contains a plot of the criteria Hamiltonian path length, anti-Robinson events (\code{AR\_events}) and stress using the Moore neighborhood. Clearly, the methods which directly try to minimize the Hamiltonian path length (hierarchical clustering with optimal leaf ordering (\code{OLO}) and the TSP heuristic) provide the best results concerning the path length. For the number of anti-Robinson events, using the simulated annealing heuristic (\code{ARSA}) provides the best result. Regarding stress, the simulated annealing heuristic also provides the best result although, it does not directly minimize this loss function. \subsection{Registering new methods} \label{sec:registering} New methods to calculate criterion values and to compute a seriation can be easily added by the user via the method registry mechanism provided in \pkg{seriation}. Here we give a simple example of how to implement and register a new seriation method. In the registry we distinguish between methods for different types of input data. With the following two commands we produce a list of the available seriation methods for input data of class \code{dist} and \code{matrix}. <<>>= list_seriation_methods("dist") list_seriation_methods("matrix") @ To get detailed information on a seriation method use the following. <<>>= get_seriation_method("dist", name = "ARSA") @ To add a new seriation method, we first have to implement the seriation code as a function with the two formal arguments \code{x} and \code{control}, and for arrays also an additional argument \code{margin}. \code{x} is the data object and \code{control} contains a list with additional information for the method passed on from \func{seriate}. The function has to return a list of objects which can be coerced into \code{ser\_permutation\_vector} objects (e.g., a list of integer vectors). The elements in the list have to be in order corresponding to the dimensions of \code{x}. In this example we just create a method to return a permutation which reverses the original order of the objects, i.e., which returns the reverse identity order. <<>>= seriation_method_reverse <- function(x, control = NULL, margin = seq_along(dim(x))) { lapply(seq_along(dim(x)), function(i) if (i %in% margin) rev(seq(dim(x)[i])) else NA) } @ The function produces integer sequences of the correct lengths, one for each dimension of \code{x} (\code{control} is not used). Since the function works for \code{matrix} and \code{array} we can register it for both data types under the short name `Reverse'. <<>>= set_seriation_method("matrix", "New_Reverse", seriation_method_reverse, "Reverse identity order") set_seriation_method("array", "New_Reverse", seriation_method_reverse, "Reverse identity order") @ Now the new seriation method is registered and can be found by the user and applied to data. <<>>= list_seriation_methods("matrix") o <- seriate(matrix(1, ncol = 3, nrow = 4), "New_Reverse") o get_order(o, 1) get_order(o, 2) @ Criterion methods can be added in the same way. We refer the interested reader to the documentation accompanying the package for detailed information and an example. If you have implemented a new criterion or seriation method, please consider submitting the code to one of the maintainers of \pkg{seriation} for inclusion in a future release of the package. \subsection{Heat maps} A heat map is a shaded/color coded data matrix with a dendrogram added to one side and to the top to indicate the order of rows and columns. Typically, reordering is done according to row or column means within the restrictions imposed by the dendrogram. Heat maps recently became popular for visualizing large scale genome expression data obtained via DNA microarray technology \citep[see, e.g.,][]{seriation:Eisen:1998}. From Section~\ref{sec:hierarchical_clustering} we know that it is possible to find the optimal ordering of the leaf nodes of a dendrogram which minimizes the distances between adjacent objects in reasonable time. Such an order might provide an improvement over using simple reordering such as the row or column means with respect to presentation. In \pkg{seriation} we provide the function \func{hmap} which uses optimal ordering and can also use seriation directly on distance matrices without using hierarchical clustering to produce dendrograms first. For the following example, we use again the randomly reordered iris data set \code{x} from the examples above. To make the variables (columns) comparable, we use standard scaling. <<>>= x <- scale(x, center = FALSE) @ To produce a heat map with optimally reordered dendrograms (using by default Optimal Leaf Ordering), the function \func{hmap} can be used with its default settings. <>= hmap(x, margin = c(7, 4), cexCol = 1, row_labels = FALSE) @ With these settings, the Euclidean distances between rows and between columns are calculated (with \func{dist}), hierarchical clustering (\func{hclust}) is performed, the resulting dendrograms are optimally reordered, and \func{heatmap.2} in package \pkg{gplots} is used for plotting (see Figure~\ref{fig:heatmap}(a) for the resulting plot). <>= hmap(x, method = "MDS") @ If a seriation method is used that does not depend on dendrograms, instead of hierarchical clustering, seriation on the dissimilarity matrices for rows and columns is performed and the reordered matrix with the reordered dissimilarity matrices to the left and on top is displayed (see Figure~\ref{fig:heatmap}(b)). A \code{method} argument can be used to choose different seriation methods. <>= #bitmap(file = "seriation-heatmap1.png", type = "pnggray", # height = 6, width = 6, res = 300, pointsize=14) pdf(file = "seriation-heatmap1.pdf") hmap(x, margin = c(7, 4), row_labels = FALSE, cexCol = 1) tmp <- dev.off() @ <>= pdf(file = "seriation-heatmap2.pdf") hmap(x, method="MDS") tmp <- dev.off() @ \begin{figure} \begin{minipage}[b]{.48\linewidth} \centering \includegraphics[width=\linewidth]{seriation-heatmap1} \\ (a) \end{minipage} \begin{minipage}[b]{.48\linewidth} \centering \includegraphics[width=\linewidth]{seriation-heatmap2} \\ (b) \end{minipage} \caption{Two presentations of the rearranged iris data matrix. (a) as an optimally reordered heat map and (b) as a seriated data matrix with reordered dissimilarity matrices to the left and on top.} \label{fig:heatmap} \end{figure} \subsection{Bertin's permutation matrix} \cite{seriation:Bertin:1981,seriation:Bertin:1999} introduced permutation matrices to analyze multivariate data with medium to low sample size. The idea is to reveal a more homogeneous structure in a data matrix~$\mathbf{X}$ by simultaneously rearranging rows and columns. The rearranged matrix is displayed and cases and variables can be grouped manually to gain a better understanding of the data. %To quantify homogeneity, a purity function %\begin{displaymath} % \phi = \Phi(\mathbf{X}) %\end{displaymath} %is defined. Let $\Pi$ be the set of all permutation functions %$\pi$ for matrix $\mathbf{X}$. %Note that function $\pi$ performs row and column permutations on a matrix. %The optimal permutation with respect to %purity can be found by %\begin{displaymath} % \pi^* = \argmax\nolimits_{\pi \in \Pi} \Phi(\pi(\mathbf{X})). %\end{displaymath} %Since, depending on the purity function, finding the optimal %solution can be hard, often a near optimal solution is also acceptable %for visualization. % %A possible purity function $\Phi$ is: %Given distances between rows and columns of the data matrix, define purity as %the sum of distances of adjacent rows/columns. Using this purity function, %finding the optimal permutation $\pi^*$ means solving two (independent) TSPs, %one for the columns and one for the rows. To find a rearrangement of columns and rows which reveals structure a purity function is used. A possible purity function is: Given distances between rows and columns of the data matrix, define purity as the sum of distances of adjacent rows/columns. Using this purity function, finding the optimal permutation means solving two (independent) TSPs, one for the columns and one for the rows which can be done very conveniently using the infrastructure provided by \pkg{seriation}. As an example, we use the results of $8$ constitutional referenda for $41$ Irish communities~\citep{seriation:Falguerolles:1997}\footnote{The Irish data set is included in this package. The original data and the text of the referenda can be obtained from~\url{http://www.electionsireland.org/}}. To make values comparable across columns (variables), the ranks of the values for each variable are used instead of the original values. <<>>= data("Irish") orig_matrix <- apply(Irish[,-6], 2, rank) @ For seriation, we calculate distances between rows and between columns using the sum of absolute rank differences (this is equal to the Minkowski distance with power $1$). Then we apply seriation (using a TSP heuristic) to both distance matrices and combine the two resulting \code{ser\_permutation} objects into one object for two-mode data. The original and the reordered matrix are plotted using \func{bertinplot}. <<>>= o <- c( seriate(dist(orig_matrix, "minkowski", p = 1), method = "TSP"), seriate(dist(t(orig_matrix), "minkowski", p = 1), method = "TSP") ) o @ In a newer version of the package this can be also done with the new heatmap seriation method for matrices. <<>>= get_seriation_method("matrix", name = "heatmap") o <- seriate(orig_matrix, method = "heatmap", dist_fun = function(d) dist(d, "minkowski", p = 1), seriation_method = "TSP") o @ <>= bertinplot(orig_matrix) bertinplot(orig_matrix, o) @ <>= bertinplot(orig_matrix) @ <>= bertinplot(orig_matrix, o) @ \begin{figure} \centering \includegraphics[width=15cm, trim=60 60 0 0]{seriation-bertin1} \\ (a) \includegraphics[width=15cm, trim=60 60 0 0]{seriation-bertin2} \\ (b) \caption{Bertin plot for the (a) original arrangement and the (b) reordered Irish data set.} \label{fig:bertin} \end{figure} The original matrix and the rearranged matrix are shown in Figure~\ref{fig:bertin} as a matrix of bars where high values are highlighted (filled blocks). Note that following Bertin, the cases (communities) are displayed as the columns and the variables (referenda) as rows. Depending on the number of cases and variables, columns and rows can be exchanged to obtain a better visualization. Although the columns are already ordered (communities in the same city appear consecutively) in the original data matrix in Figure~\ref{fig:bertin}(a), it takes some effort to find structure in the data. For example, it seems that the variables `Marriage', `Divorce', `Right to Travel' and `Right to Information' are correlated since the values are all high in the block made up by the columns of the communities in Dublin. The reordered matrix confirms this but makes the structure much more apparent. Especially the contribution of low values (which are not highlighted) to the overall structure becomes only visible after rearrangement. \subsection{Binary data matrices} Binary or $0$-$1$ data matrices are quite common. Often such matrices are called \emph{incidence matrices} since a $1$ in a cell indicates the incidence of an event. In archeology such an event could be that a special type of artifact was found at a certain archaeological site. This can be seen as a simplification of a so-called \emph{abundance matrix} which codes in each cell the (relative) frequency or quantity of an artifact type at a site. See \cite{seriation:Ihm:2005} for a comparison of incidence and abundance matrices in archeology. Here we are interested in binary data. For the example we use an artificial data set from~\cite{seriation:Bertin:1981} called \emph{Townships}. The data set contains $9$ binary characteristics (e.g., has a veterinary or has a high school) for $16$ townships. The idea of the data set is that townships evolve from a rural to an urban environment over time. After loading the data set (which comes with the package), we use \func{bertinplot} to visualize the data (\func{pimage} could also be used but \func{bertinplot} allows for a nicer visualization). Bars, the standard visualization of \func{bertinplot}, do not make much sense for binary data. We therefore use the panel function \func{panel.squares} without spacing to plot black squares. <>= data("Townships") bertinplot(Townships, panel = panel.tiles) @ The original data in Figure~\ref{fig:binary}(a) does not reveal structure in the data. To improve the display, we run the bond energy algorithm (BEA) for columns and rows $10$ times with random starting points and report the best solution. <>= ## to get consistent results set.seed(10) @ <>= o <- seriate_rep(Townships, method = "BEA", criterion = "ME", rep = 10) bertinplot(Townships, o, panel = panel.tiles) @ The reordered matrix is displayed in Figure~\ref{fig:binary}(b). A clear structure is visible. The variables (rows in a Bertin plot) can be split into the three categories describing different evolution states of townships: \begin{enumerate} \item Rural: No doctor, one-room school and possibly also no water supply \item Intermediate: Land reallocation, veterinary and agricultural cooperative \item Urban: Railway station, high school and police station \end{enumerate} The townships also clearly fall into these three groups which tentatively can be called villages (first~$7$), towns (next~5) and cities (final~2). The townships B and C are on the transition to the next higher group. \begin{figure} \centering \includegraphics[width=12cm, trim=0 40 0 30]{seriation-binary1} \\ (a) \includegraphics[width=12cm, trim=0 40 0 30]{seriation-binary2} \\ (b) \caption{The townships data set in original order (a) and reordered using BEA (b).} \label{fig:binary} \end{figure} <<>>= rbind( original = criterion(Townships), reordered = criterion(Townships, o) ) @ BEA tries to maximize the measure of effectiveness which is much higher in the reordered matrix (in fact, 65 is the maximum for the data set). Also the two types of stress are improved significantly. \subsection{Dissimilarity plot} Assessing the quality of an obtained cluster solution has been a research topic since the invention of cluster analysis. This is especially important since all popular cluster algorithms produce a clustering even for data without a ``cluster'' structure. %A method to judge the quality of a cluster solution is by inspecting a %visualization. For hierarchical clustering %dendrogramms~\cite{seriation:Hartigan:1967} are available which show the %hierarchical structure of the clustering as a binary tree and cluster quality %can be judged by looking at the dissimilarities between objects in a cluster %and objects in other clusters. However, such a visualization is %only possible for heirarchical/nested clusterings. % %\marginpar{Cite Pison et al 1999 and Kaufmann and Rousseeuw} %For the an arbitrary partitional clustering, the original objects can %be displayed in a 2 dimensional scatter plot %after using dimensionality reduction (e.g., PCA, MDS). %Objects belonging to the same cluster can be marked and thus, if the %dimensionality reduction preserves a large proportion of the %variavility in the original data, the separation between clusters can be %visually judged. % %Silhouettes Matrix shading is an old technique to visualize clusterings by displaying the rearranged matrices~\citep[see, e.g.,][]{seriation:Sneath:1973,seriation:Ling:1973,seriation:Gale:1984}. Initially matrix shading was used in connection with hierarchical clustering, where the order of the dendrogram leaf nodes was used to arrange the matrix. However, with some extensions, matrix shading can also be used with any partitional clustering method. \cite{seriation:Strehl:2003} suggest a matrix shading visualization called \emph{CLUSION} where the dissimilarity matrix is arranged such that all objects pertaining to a single cluster appear in consecutive order in the matrix. The authors call this \emph{coarse seriation}. The result of a ``good'' clustering should be a matrix with low dissimilarity values forming blocks around the main diagonal. However, using coarse seriation, the order of the clusters has to be predefined and the objects within each cluster are unordered. The dissimilarity plots implemented by the function \func{dissplot} in \pkg{seriation} improve \emph{CLUSION} using seriation methods. It aims at visualizing global structure (similarity between different clusters is reflected by their position relative to each other) as well as the micro structure within each cluster (position of objects). To position the clusters in the dissimilarity plot, an inter-cluster dissimilarity matrix is calculated using the average between cluster dissimilarities. \func{seriate} is used on this inter-cluster dissimilarity matrix to arrange the clusters relative to each other resulting in on average more similar clusters to appear closer together in the plot. Within each cluster, \func{seriate} is used again on the sub-matrix of the dissimilarity matrix concerning only the objects in the cluster. For the example, we use again Euclidean distance between the objects in the iris data set. <<>>= data("iris") iris <- iris[sample(seq_len(nrow(iris))), ] x_iris <- iris[, -5] d_iris <- dist(x_iris, method = "euclidean") @ First, we use \func{dissplot} without a clustering. We set \code{method} to \code{NA} to prevent reordering and display the original matrix (see Figure~\ref{fig:dissplot1}(a)). Then we omit the method argument which results in using the default seriation technique from \func{seriate}. Since we did not provide a clustering, the whole matrix is reordered in one piece. From the result shown in Figure~\ref{fig:dissplot1}(b) it seems that there is a clear structure in the data which suggests a two cluster solution. <>= ## plot original matrix dissplot(d_iris, method = NA) @ <>= ## plot reordered matrix dissplot(d_iris, main = "Dissimilarity plot with seriation") @ <>= pdf(file = "seriation-dissplot1.pdf") <> tmp <- dev.off() pdf(file = "seriation-dissplot2.pdf") <> tmp <- dev.off() @ \begin{figure} \begin{minipage}[b]{.48\linewidth} \centering \includegraphics[width=\linewidth]{seriation-dissplot1} \\ (a) \end{minipage} \begin{minipage}[b]{.48\linewidth} \centering \includegraphics[width=\linewidth]{seriation-dissplot2} \\ (b) \end{minipage} \caption{Two dissimilarity plots. (a) the original dissimilarity matrix and (b) the seriated dissimilarity matrix.} \label{fig:dissplot1} \end{figure} Next, we create a cluster solution using the $k$-means algorithm. Although we know that the data set should contain $3$ groups representing the three species of iris, we let $k$-means produce a $10$ cluster solution to study how such a misspecification can be spotted using \func{dissplot}. <>= set.seed(1234) @ <<>>= l <- kmeans(x_iris, 10)$cluster #$ @ We create a standard dissimilarity plot by providing the cluster solution as a vector of labels. The function rearranges the matrix and plots the result. Since rearrangement can be a time consuming procedure for large matrices, the rearranged matrix and all information needed for plotting is returned as the result. <>= res <- dissplot(d_iris, labels = l, main = "Dissimilarity plot - standard") @ <>= pdf(file = "seriation-dissplot3.pdf") ## visualize the clustering <> tmp <- dev.off() pdf(file = "seriation-dissplot4.pdf") ## threshold plot(res, main = "Dissimilarity plot - threshold", threshold = 3) tmp <- dev.off() @ \begin{figure} \centering \includegraphics[width=10cm]{seriation-dissplot3}\\ (a) \includegraphics[width=10cm]{seriation-dissplot4}\\ (b) \caption{Dissimilarity plot for $k$-means solution with 10 clusters. (a) standard plot and (b) plot with threshold.} \label{fig:dissplot3} \end{figure} <<>>= res @ The resulting plot is shown in Figure~\ref{fig:dissplot3}(a). The inter-cluster dissimilarities are shown as solid gray blocks and the average object dissimilarity within each cluster as gray triangles below the main diagonal of the matrix. Since the clusters are arranged such that more similar clusters are closer together, it is easy to see in Figure~\ref{fig:dissplot3}(a) that clusters 6, 3 and 1 as well as clusters 10, 9, 5, 7, 8, 4 and 2 are very similar and form two blocks. This suggests again that a two cluster solution would be reasonable. Since slight variations of gray values are hard to distinguish, we plot the matrix again (using \func{plot} on the result above) and use a threshold on the dissimilarity to suppress high dissimilarity values in the plot. <>= plot(res, options = list(main = "Seriation - threshold", threshold = 3)) @ In the resulting plot in Figure~\ref{fig:dissplot3}(b), we see that the block containing 10, 9, 5, 7, 8, 4 and 2 is very well defined and cleanly separated from the other block. This suggests that these clusters should form together a cluster in a solution with less clusters. The other block is less well defined. There is considerable overlap between clusters 6 and 3, but also cluster 3 and 1 share similar objects. Using the information stored in the result of \func{dissplot} and the class information available for the iris data set, we can analyze the cluster solution and the interpretations of the dissimilarity plot. <<>>= #names(res) table(iris[res$order, 5], res$label)[,res$cluster_order] #$ @ As the plot in Figure~\ref{fig:dissplot3} indicated, the clusters 10, 9, 5, 7, 8, 4 and 2 should be a single cluster containing only flowers of the species Iris setosa. The clusters 6, 3 and 1 are more problematic since they contain a mixture of Iris versicolor and virginica. To illustrate the results of the dissimilarity plot in case a clustering with a $k$ smaller than the actual number of groups in the data is used, we use the Ruspini data set which consists of 75 points in four groups and is also often used to illustrate clustering techniques. We load the data set, calculate distances, perform $k$-means clustering with $k=3$ (although the real number of groups is 4) and produce a dissimilarity plot. <>= data("ruspini", package = "cluster") d <- dist(ruspini) l <- kmeans(ruspini, 3)$cluster dissplot(d, labels = l) @ \begin{figure} \centering \includegraphics[width=10cm]{seriation-ruspini}\\ \caption{Dissimilarity plot for $k$-means solution with 3 clusters for the Ruspini data set with 4 groups.} \label{fig:ruspini} \end{figure} The dissimilarity plot in Figure~\ref{fig:ruspini} shows that cluster 3 actually should be two separate clusters represented by the two clearly visible darker triangles next to the main diagonal. The dissimilarity plot using seriation is a useful tool to inspect the result of clustering. It is especially useful to spot misspecifications of the number of clusters employed. A more detailed treatment of dissimilarity plots as a tool for exploring partitional clustering can be found in \cite{seriation:Hahsler+Kornik:2011}. \section{Conclusion} \label{sec:conclusion} In this paper we presented the infrastructure provided by the package~\pkg{seriation}. The infrastructure contains the necessary data structures to store the linear order for one-, two- and $k$-mode data. It also provides a wide array of seriation methods for different input data, e.g., dissimilarities, binary and general data matrices focusing on combinatorial optimization. New seriation methods can be easily incorporated into the \pkg{seriation} framework by the user with the method registry mechanism provided. Based on seriation, \pkg{seriation} features several visualization techniques. In particular, the optimally reordered heat map, the Bertin plot and the dissimilarity plot present clear improvements over standard plots. A natural extension to \pkg{seriation} is the synthesis of ensembles of seriations into a ``consensus'' one. Such ensembles do not only arise when using different seriation methods, but also when varying data or control parameters to obtain more robust solutions (see e.g.~\cite{seriation:Jurman:2008} for a recent application of such ideas in a molecular profiling context). The \proglang{R}~extension package \pkg{relations}~\citep{seriation:Hornik+Meyer:2008} contains a variety of methods for obtaining consensus \emph{relations}, covering consensus seriation (where the relations are linear orders on the objects) as a special case. Future work on \pkg{seriation} will focus on adding further seriation methods, such as for example methods for higher dimensional arrays and methods for block seriation which aim at finding simultaneous partitions of rows and columns in a data matrix~\citep[see, e.g.,][]{seriation:Marcotorchino:1987}. \section*{Acknowledgments} The authors would like to thank Michael Brusco, Hans-Friedrich K{\"o}hn and Stephanie Stahl for their seriation code, Fionn Murtagh for his BEA implementation and the anonymous reviewers for their valuable comments and suggestions. % %\bibliographystyle{abbrvnat} \bibliography{seriation} % \end{document} seriation/inst/README_files/0000755000176200001440000000000014453272107015350 5ustar liggesusersseriation/inst/README_files/seriation-2.png0000644000176200001440000007103614610032223020205 0ustar liggesusersPNG  IHDRHc pHYsod IDATxy\73DDoE)cUeպիVЫŭTbJ -T jn{E d?vn.kDJycr3g&!ߜ3gf( NO7< BA2@! x d< BA2@! x d< BA2d@ ŋWxbԮ֍>}گ_nn79n4cL?]ϟϴ<++KR?֢EXN8AQ@ ʁ ;-[͛t[7o޼y7[򲳳sΝ;bO7Gvvvjjʕ+{-cƎ,}jO> 6mVoЃ90Ïϟ?g .`ڵ|۪~!?c 6OcccddرcͧO~fW^?~꫆6nUUݻ@B4ItttdR={d#GNN0e}3Ǐg~嗢 ,|SZZPYY9++***-U/_>SE9y$ɔ]n!Gf4e3/_&|8[*77Imfq߮y1'!''ҥK nnnV1UuS,3DFhh(!۷m1<Ⱦ[2) .۷/[!n߾|*))-Zh= 0)s9u7|ӧO &τ <ӧO;w555/J{VUUҿ 1N@ӧҥKƌäX[[755 18-^ٌD9qD楲riiicc#;Sw߷U8oWK˨lkkˤ,Zh+V`> uuuL3g0y>S-짂2a„/ɉyIQTQQ f!87550J ~h!<<<;v0)c1HIIn1,,ɳqF&EEW^1)ɃxbeeǬRRRZl|v6!qH}Xt)(b,6mɓJx~UaoWKKeee/^oS ̆$O>aٷ@tJJ>}_~E#faСÇ}YSSKKK&B8NRO33~"xyykUoWKK/^$1833s̼⧢-@L k۷o3L:;!nb˯^*Z5ܹsl .4;_HQ3[YY$C v=J[xŋ:Dt钓SBB30iӦSN1!1t!N3Hyazz:۷7of[^%J&NKb6}۶mkjjb7m,SF|>Py q߮#33mg~0ڶ.AWNv kƌxCC_gaB?L7oޕ+W(JNN~hUSL9yP(tuu7oo˗/g͟??//eҤI?w}ѣB[똛BnܸQYYiggcǎ15wkO>VVV=j9%qA L6mɒ%fffLȱ3gN;B׮]7n+W_9aڴik׮cVM}م6l>H;OMM\~}OEf SN>'''.mq|>ٳg}eI{ݻw>ACAA2@! x d< BA2@! x d< BA2@! x d< BA2@! x d< BA2H -۶mV&VH׃>s@ Au|({ Ru}4*ӤQ-xjPURJJR%l:*Ҩo)..FQQQ˗/lu=\A7Q)x#~RYGSZ?T3!dj#%;&FQmYY4;vlgKxBA| vEzz2=x34;HB@! oHB:vUgllbeebŊT}vfYMMm޽L/xŋǍccc?>#G|G RYT, C6l`oop!nnnG;wnONNz%iI{ݝу<~X]]Ç2/_=x`.;y|&644t***k׮mCKKt:0jԨ찰 nݺdɒo͛7F***"|駇 >z(NjHIIi[wA<ѣG߽{… ?)--BQ/_⬭ߖEU8JII[XX9sfРA ㏙̆/_TRR"?~Gݺuɓ'BmIPZ|xيPBӧOuttKQMMo߾˗/>\]]#55UWWmIPhBBZnx C{/^({]B~eeh?;//ÇUUUNNNcǎ---}SLMMߖE-+++mm۷𦦦ׯ1ԔŬjhhpqq9y͛7߾}lٲ0gے@:rHMM͉'3ԩS̬& C{322Ǝe˖~Ǐ/,,o!Ç3gή]Ξ=󃂂 1a„{UTT- H!GG={(++;-<$|xΜ96m{ٳg̒~777uօ'$$\zu۶mmmH"͛'O?p;v۷ӧOě,z蘃ñcZۧOfAAAAAA)fbĪ*qjUUU}TTT<<<׭[j_-pK-..&ذ)666mED]paIIIUǒAc%%%\. [n9sf[kKKK !ZZZl ˥iFGGG4guuYbbb ԕ#΅P(p8?nu-ho4M(YBma3w!MVVVnVaJJʹstHEQ>dS evZEEEQE/(ĉ"z _hB$1\Szz:s37ɾ\xaXX{eޅ+Vx5k8;;'$$TUU-XYk׮ 4Htn=ŋ[XX0nܸqs,Ai:yeR|* U%K*}{wj4ླ49w޽{wWJ-d< S]Aw~]"= =x< nUKwHB@! %UmoG^^PmXn!d֭=LzrjSNe.]jjjtR業mϵ 5jzj??l;CZ[1z CBaDDf@@@ee%n:[[[uuQF[reCC]jjjFFFzz5 4HII),,lɒ%555ݫ/,, ݿȑ#; $ouCi۶m߻woQQѐ!C222x<̒k777[[ۈm۶EEE^:((HEEeȑΝrYEI4*-?l~RY[SYJ5boqX+=ZV&vEVft cҨۋW\\,>233c7o]v[g >|x? >/VIz _hZ[ (LA2C w$리 ЃBDK)҄< BA[nFʦ&R+{#J+JK]{U$k_RDwS$jkvG`@򅦉KPg Ѓ#u46=@aDσ=<xYA/}}}wXd֭55{'//͛=2C2HII)99YGLL[~~~{m,OOO33l޼iiiI 'hfeh̙3^|b7|l؟  Ç'TUU1/<訪jgg~ќB0""RSS3 I711IHHpuuURR dW544|ӧO?t萮.JEEȑ#lsx̲;DoiiiBF}t^z%# ½{!F"ϟ?㮮sMLLdsnܸpQQQ'ObWZ*---22I }/Xv-{]nnn#G>}~ٵÆ ۹sC.\˖5eee9TPPp-@ q >RSSG9qDfrK_^t{׿GGǏK-x0d6mDY~}tttJJVVVbb%KR?pBss5kְ7p &TTT08p`jjjiiiPPŋϝ;ǜ5k֛7oBGG={(++;G3!!!{]dɱcdž p9 6Gi7sp~~XyvRrә|>?++߿Y6UUSNݼyMzq~:E v0]S+x<ޚ5k,XڵkWvv\\\ƌ3uH}}s߿?!!A!,SWUTF|ifm''9AJ5RR̈́*i5[[ 6'޽{̲ _h",z F{& x!z34%*ɯ҂< B -ud= ^899999|{YOsN]]l4iRmmŋ[>@VIv<{վ[˩ׯ_xbw^x'OVVVlUUUϦ$$$*))ijjVVVv ꂃMLLLLL.\;555cbbtdijjs?>~Ǐwuu;wnbb"6<<\OO/''gժUiiijBlٲw^xx8WTT>'̙3555SNC_oEs۷SNH&ֺխ^:$$`ffDQ/]ǖmuU;fggggggddx#wwdz7n_ gϞ- gg犿7NQlmmlkU;^~]KKee倀6__ߴ4Bț7o233O.# Ѓ/:::ϟ8p}6lذj*BHaa!!d̘1WWW3h.VjR###D~~~qqq>kjjj]AKt ߚ !Ǐ?fOOÇ3u=:GsU;TTTcƌOOO_aڰaٳ߾}kggɮtqqv*9rdeeeVV.RSSlçO<HMN}ڵ;v쨫-cǎڸq/^a//8p ::<11q] 322/_i&>-Z駟'Lӯ_4@QttYWXX{:uͭ+xyy)oeaw5L_ z)՜ GIfB4W(++tI"R[U2ͦȞ̨o6c,z0fg讝߈@ @B+++o>EE|8$P133ɱ %8=h#߈{ My;!  ;_#LSRHf#Ҩ/Z}Ts(%)ռZ)Lfi(iiH}p|SWPҩz dz w$x{=x 0DEH0g Ѓ9CӒ{;d< B#gϞ ?~|xxx]]]<nnn{=Z) ҝm#ˍɓ'WVVΛ7/&&fС<+V߿XXƍ---?e˖`@2d'9uָ?M\|)SfϞ}My;w~gLQF-[l޼yCs[|>_QU;DQn Ѓ}|>Ŋnnnѝbaa}۷o:tkԨQltg̟?ݻKPn:[[[uuQF HmIEEŚq߾}ܹļtwwgbmm-Zg:U!@wanU6^B~V޿ʪO>?na b3`vP(,--e^rܶ+<eޞ={Zp£G 7ظjժW-//g׾x(6BnuUr8|4H2σEEŘӧONj3!$::ƍի?boox1vѣGڷo_ ̙3_dɒI&8p@YY WWϻr8gϦ7bbbg\.555###==]Vu{B<o׮];vxŠABBBK 6Obb ׬Y󭭭?{l6öm[TT4dȐ וVu{%z{<>55uƍ>tppزe}پÇ͛7/44TQk0fTO7*TVJ5BtK@_Z}T4|Y2_7MK??|ěx'NܻwK߿obb,ڵk#""-[6qذ5ktvs 7ok֬3f̘1#::Z$;)(()((Hپ}{ۍ!ze֖:H)|~wԪ j:$ʪ)̀~RBJ5(KfBH]cOa{ERPJiT +Vx5k8;;'$$TUU-XYk׮\|e:@ЄH0lٲ̪7nٳyzMussl=;ڵsΉވ~4M.Xn 3GSd@t%(ҳЃAw:w=x =W^x***VVV+Vh# ݼy[ :x z6]x%66VMMݻqqqgϞvZWnyׯ_ucSxhӆ 8!ȑ#s}ghjj(JIIm@`cuuu&3fhhȼ ֭UWW5jɓ'ٜ***Ga_Ι3BF}t^zE9x𠣣"G]r~qqwDO{=}!Ϟ=۹s-[/^L(++[zW;ur\@WWWNqww[zuHH)--(+AڤR^^啛4xBn߾wijQ7n\YYYQQM;у6 MMMBȹsBCCO:U\\p 744 _XXH3fLjBF$<.??_QQŋ...w%rv/( ꖉfOE:t(At~@7`]_:+++mm۷ B6#F +**;v]{ѡC2s8G1o޼rJM)++gff)...R#!zhrbbYƎoddÇ&''BLLL>쳕+W644٥fdd3Ň sN 33׿|YII֭[!!!%%%ٱqqq=`ii~;w>}pԨQvbзmۦwޢ!Cddd0B\__pB;!d֬Y999NNNϞ=[~,X#; 򃦉Ф$(ҳ=(((DDDDDD\eccs˛0a“'Oؗ˗/_|yJJJpys Em͹iC -EY x!z/4MmM z2=x;{;dz >JRW;Jr) ػ QRoR̈́i}T3/-j |$p<<x!z3$ 0DrG;բ MNNNmmm77~%4BIzᝃ!zhmTT!D(ǻt=]]]???G}3fDQ4 d !KG\R__rAGGGUUU;;3LMMJ555cbbirA!Mwli/0aSPPk.=={xx?~uܹ??7o2EΜ9SSS3uTBH[EZVN='''(ٳgؔ4ꢢ"## !uuuW qtt455MOOwtt$|G&&&iV;g<_\\\N|}gp+ƌ/qV/P蜼|if|"BIntfѣy'SN]t-sꆆ888dggűvѿ'f<ݻ>>>̲eBBٳ[ͼ~z]]DGG'&&.X];a555~Y@hx <);; %%%/)Z|[ٳׯ_'biV9t 55uȑ'Nk?s222$?++_z[DxVXqĉ5k\|yUUUv5mڴn<u{JJJVVNj/Ο?oaaqFJJ 6D<;ݻw,+B@&Dgu%dz ghI㽭_Q]|H(RRRz9G"`]oe\##hׯ_B!zWWW%%%MMJfo榥[TTVX^^뫭mmmf_wPQQ9rmΜ9<Y6008zʕ+BU̾ꫥK~<02 ^=3foY*<<\OO/''gժUiiiI&&&&FGG_vmܹlS0`߾}<o_|8͋)((صkҥK͛79s&11 0D/~zinhhPPh\.evNNyHHص2/^t<===fHEEE|:,B}\.ᆪLׯ_g-f222*++iccCp8=b߼ysʕV+wppPPP8y$󲴴_TIvr?ϿSNM2w-++{{ 9r/^J6lΝ;-,,֯_Vb޼y-z捶vttn˙]D"ݻ>ؾ} 8055uAAA***#Ga``0D##FuVMM w@uun2ir-n%7!z 0DE§I%R< BdTfKXJRijpZ:QxHZFunuIMoR-E@! | tv\=@a M$E/A< BArի<XEEjŊ555ڼ7o`&azݍnp^~]x%66VMMݻqqqgϞvZ߾} !7o~uZZZO: ^~mذ>++B<<<92ww>!SBB$I1_ -* ˯Ǐ3ѝ1|0CCCBѣ>NQԫW!tttTUUۿ?SiccE1/[-B111IHHpuuURR dVonnnZZZ:::EEER> ^~5*;;;,,lbtt;!$++ͭT]]=>>~Ǐwuu;wnbb"!lvg̘Ai#<<\OO/''gժUiiiI&&&&FGG_v흍%ʯ 6:;;ӇrUTT^]]]TTTdddxx8!ݽn!!!ʙ .$ZXX="̒(?~K!{ő#G !zzz=u|@fфAiiiyyy <ÇrWTT8;;WeܸqeeeEEEꮮLTN&;Ebnntx{{ļ [S555}||>|xيf9 !cƌ̙3 !Մ??۷oӧO!lvNNyHHH^N+**^xQ4ݻ2B5tPB7M?cjjuE!lʟ~iS&/=L^^YYYikko߾](rׯ1Yf;;;D;,kii9998q"55wX-ǎSQQquuMLLGW@>aRVVNLL5kرc^|yd&RAA[CCCCBBJJJccc,Y۩S2)i}aaaPPPHHHo?FƸoQ)+tWdtQ-* mVt]H6YjKbk\º$a8f6x?a: s>sinQVV611?00qc]CLQUVVaffv)n/e˲g͚UQQo>gݻw'OF9::^B]]{F{ HHHdee}n=G0A{O3o<''/7M)J.-k(YD˃*Hq?(J򢬭MQO|$OҐJJk|v4 a'1uo ;@AzIRRٳ<PѫEZZ466>}46miAzáC"""\\\._Ikhh}6JHHrx Vñcr;&YmmmYYɔ΃onPyPMQ2?wP6&Jbvgj/܀*))y---QjUUBHAA{DQQð&een̿-mmn$NYH}}ʲ 555fc_l69s /Y|Y9}# ږKP:|Ç׽^555ije61ས'܃(I^|=R\\``1ba~-a&&&W^%x) *++B7n0VQQ!j̬xK ҥK322:::d`k1ð[{{.\p8AAA:::%Sx04=|PSS?bLMM &cO? ðTiiiݽx"##_TT:~x FSWW?{,gȆ ;v,auuu4 ݐ!C^|֮E)**L611 y#G?~KsݴiB666:::?&sȑS޸qӳ)ʨ^^^Sc)Jh544 |$SC߾ϭ_^AA!22ð &YիWL&SWW`r~~BHVVÇ3FLL 0 QCCba6qD++9sL2dBHKKΝ;l6fPvv6,kĉl6a .33S]]"<<'o۶MAA/ӛoLP@<| ܹCBt:=!!xxkkk^^|ܴiӸqmr{{{iiO*++?XRR?p d0M`ͰGYYYٳȑ,Ǐ ,~***9"dddmmmy^vd\OJJ*11ƦNYY˖d2[ZZgϟ|iggg"9_T__s|6~Ӂ~H@8s̰a,--Ϝ9,_){aO$feeeii)++{9QiiiRR!!!mmmrrrL&SKK.11f2ӧ] |AAtuuݻgcc{0//oԨQ6`xzz?ɉUtY,>d 0"--pB {FͰQtuժU3glkk촶&gqq*SUUuqqq`111t:=88877!TSSs11Çd .]dlll``e˖ÇA0YVV6,,x UaO)MM/ f׮]+**ҋYxxxx`lݺ%SN{{;B(''x .z} pg!TQQHYY^ 9~֭[=zTYY1qDuyzz?^AAYVV`OdeeemF.tEtt3فĉ9k׮%r __}y{{L6mÆ ۶m+((x9222vvv/^TPPs5R啐gggIKKsss[padd$dJh*|7W^^Ecc#䰰E.7EDD >ZQQ߇  <zaxSSFKLL{ٳ;::t L&dJggg+**jhhTVVϞ=;%%EJJ`8C}{={{"%߼#h;`@=G1ӦM3f̰aè>5ҷo߾}455MMMONJ8CEEE񏥤lgbbl2Ʒ۰aúu^KWÇ5kL* /  "RZZj]q76674\@@>&OFuW^OOONNN/$etǏ߿OJ #P@Q?|/BÃ!߱c_vݽ !a؎11KWPP ##Ңij䘛I ul۶ 00P[[򊉉rw丸8OOӧ/]!4e___E$ҡݔviX+W<{L]]{2R {+x0Ѝ9ȑ#OrJZZڧOwe/ommMVS)W~VVV]u[Hn4ZQQoJ4e|?EFF&;;{̙|_pˑW^EEEܾ}H)}`-GckkK|=rY HJJc[%==]JJx xx---sΝ4iJFRR(}@.z0Q .::Ĥ߅k{355%9uK-%%}vsss5;g޽_6h "3>}k# }>~zH &Lf͚W^1L]]]=Zͦʏҥ{)]effs_; p2_uuuwMJJzAKK ):@]cc#~oð;wt:=!!`#_x  uKխ]vԩfLf݃677'+**@E006#//~#0hhh k9IIɴYfҰ^G*^g2=-ts"]AL0!&&FWWH2Ղ6mڴt!CTVVŅ=zl@ @_rK\\˗W^]`&ɓ'[[[ڵFv7He Tbb o`2---nj{p˖-=]vɒ%'O&@ ` =<<[[[|I&IvuuݺukaaAx"=== ⢡QUUÇ={0 sں_#җhjj255%۫TUUK7JGM63fDEELNNN1bĒ%KZUkkkBB#mmm'"SǢEӹvvvٍ92""H2u!KK7I{'Op86~={888={Ν;-,,LRSSz wrrRWWﲪҺu={v-"ݻw/)))))͛7т@A'-Z{L&6RWWpvv=vJ{ѩ[&%%vNHHHIIIMM{˷cǎq.f0{Ǐjjj-Z4gVUU]t)>>>--K=+}qqeff&Yɠ?:??իW:x`qq1) !4l0???ރǎ۷o_ee%߱T/O]qΜ9{pʕO>%rgRMMf8Z߼3 ssskג;:::;;JZ _lvJJMX'+h &X,ʦp\zUNN#laad!OZZի]fffmkkSPPHJJ"ݫYN8aee%&&FΝ{ԩ@ ;0ڵr"""L&3$$`rJJtƼIDAT Ǝtyf޼y&&&G%`ddDz/:/{5 .M`0<==ϟ?D┄yĄFFF=b0s̉rppPPP  tBſ{YYI&L@\ϯ(88xǎeރ! u)EuFEEţG*++544&NH())߿ʕ߿иqㆥŋ}}}kjj_vݽ !a) 4}'Ol۶733 ŋ޽[RR800pǎlu(}ٳ;wv9r%8|YRz333Eoddd29}K"L`0@_ٰaz~~>0>>!aϟMMMf]_q+**fR6 #ӝnvIzzz|g~xzСO<῭V]]ԄaXJJĉϞ=K$kܹSL?~a---iӦqL <F}>zhpmmmRNT^^RVVFJf{{;B(''.{a؞={ë8NUUŃ lllGDn۶ ðÇʺIJJ]ݵEEEN3}t0Ajjj!YYهb6f11Tɒ.%%E0 (`b0iii܇C>v[VFAu=1s5j;777:pBnnncǎ/ּ:aBB˗/ڵ k߳gτ ܌\TTT^^naa}vAAA?~3Ν;)N-,,)ZNDD[n%k(\rr?wFYffѣRLL-<<!BCC/\;!.!!f󒐐oL&)>>>^^^FmmmjjjHHIx0@;wՕF3gOq8$W\o*J|ђ'%%U[[}B7$vMGGGCUUwݗECCuy yQ7ݽ9(((00!`06leyc Ġjǎ3f055} B'=zt ڿhoW9EԽu(((x)w_bggg6(iCv]P7qݺuK+((4777E_#dgg،3fٲep())%$$1bįJi4 0;;>}J'{!emme֒N3(?p8Jy***ݼ0?~O79B0оѣGCܻstt/<'''44fffGUPP`٢JJJ'O{ڬYsn߾_8 [~~CBqqq7˖-377't?͘pw䂃e4 v hrrraaa_|ĉ;w#H쉡TDDD@@I8y䴴4*xA4rs}}}++Ç)++"6oޜQPP_;֬Yg;R]]{L?5~/^P}ŋGGGS\ZZ:gΜ.g͚3Ǎӳ7n;v,g|g9s&##XTTdcc[4 `$ ե"{_IIFFFսwW^^ިQ\fcttʕ+O h6l򊉉a2#F@~ҥK*--ʲhoo1cFhhh\\Mf _'L p%%%_ uVsݹsgʔ)܁obbb7n ͂EZZ_^g%.JAvFM:sIAl c?~Ȼr^^1 lvII w$|~?ost钇Gkkk5|eeeT3f̸uRRR&&&&&&\}f޹sMMM#G7oǠA iiwݽ{S$za% 0 az>66VTT _#ð@_СChi'O&N9r6BhԩDׯ-,,Νo[ `b[(w ?ݾ7m4n8kkk 544? F"C|KK˨QƎ{MٺDNeeСCccc_`ڵ|'把N4i4}NNÇ@NLOOZӥlhh033SUU-((x٤Ih4Ǐ vrrro޼ԛ7ooNOYYݻwCޭkO55˗/N.J@P=xH⢩IY.// ;;3f|ISS3;;}PܹtR ~^Ç]o2@\vmŊ6]ɭX"&&ɉ3gΜ9ȠA>}*kJv_~133,>>>{ y%B~ qww'+--ajjfY,Yqo!] o߾]o[n>}gׇ><ݽ9(((00!`06lG0YBB"99y…666n=z4*))VMMYbzzz>|L >>???@@@AAABBBCCCDDDEEEFFFGGGHHHIIIJJJKKKLLLMMMNNNOOOPPPQQQRRRSSSTTTUUUVVVWWWXXXYYYZZZ[[[\\\]]]^^^___```aaabbbcccdddeeefffggghhhiiijjjkkklllmmmnnnooopppqqqrrrssstttuuuvvvwwwxxxyyyzzz{{{|||}}}~~~ pHYsodIDATxy|EǟI2$&$`K@TnU9z.l\CЈ%7d h)bQ{ K=-JiXv=ŕ $hblQM9ʦ kP#x֛6qnϼg,ȼ01<뼎1bImhٌ)3hg#8wzTcqXT٪h󕗌j^|؁K[IWq,SJpx%ͮyX_|g2ŗtX#f]^,a%SO|i%wF=τee8o:pOP[@F!Lg2+eYlMq{SW^LLۈSEm>:-jS鸺UFޠݘIPT:ZjK_+GŸLڻ"ͷL3aKh+]-Z\bFwEPn aOTmZWs {]Ԧ[@שT:HU{$M 3bFwEP˷84f5.1ks[+bFwEP˷ @?1rr5ƷAM^{w2dQcU-,{fnv{P.RZg6cv6Mxiȅv7Y⊠U}4b40 fmJKߥ!gXk4지+>LZ5]3@w zt]Ene6cW5A_m*jFhݕ[p\PTѬӷ)56yP3lƞ ;u5gJ;/b3V8.@:KrEuglƅI4̼^Ws6D?>W j8."Ϙ?g ?,BHFw z}ٸqv7uj8./# &H7$9y[?HcQ9WViokS.Zd}TbwyGl\.{/+.IEuf3՜ *JJ/w1Oj8+hp2h-$uf3לkWIgFAj8{pq+ ^gdUZ9ԝZtx_7PƕoR:cfs^Fԝ_ݨ=-X3F27O1^0;+#{\"\g`6oŸc ћq*F"|,gPrgtZ|v/L?b^-|kdsְ!K'm.gzNrI2`t -01BG=ot6w= =wP#Λrer%&#I~b16i3|=(q2` ڌNHny> NڔT!:6S52k֬=ieA˔V?G7ixP%AbarF;KFrtkQ_9ajsRu6UNֈOfh*@yVKL X-5b_Svi;,ƃ*'cGQՙZf'H.cYU2pe5:JBw[@֫3fg mN )cY Urp{KW˱r (#^~\XNQ=bQA^}r2кd,Wg..,Z!Te'"6/ o-EY}x}h|dbKB7/Z~B1/8zux,WgtV"QsX],Ḡy|e OZdv;j>,1D$Xn̴ {V fW.!eg,KSfJ䜾Q_n7BT}Ɇ}ޢOޝ]4c^lLeܨ?A|}:ˍs 8sdA{jotQz"h3o,E3h-o|]&odln֮޷K/eg`cg}9zDv^lIaCBPQ-Sʄ9ޅYzmn7ů,T2}cBo6K24'PϜ(\j(%.;tW{cwVUl~P;}pK>SN.8S=s:̩ %rM1X.۶ﬠ(!ӨQΊW^FIEx%-;75}͡iN lG=sX~ k~ɡ)|뎢"4X]Mn2%Gk yAhKGԑLӵ#u4;wE(>YA^T%('!_Vu"#ssDgސ!3w_;sƂMyUwOQX ^B\dQOJJ6 TTSKM>.Z+ӸH9D=sQڙӔȵn5}'1bN; ~ uD%^~2#K3_3F ʙv"jv2 QX-;IK38㥕oƫyl}q?vnu_t=dF|pfMlW 7!׬5⫆N(u;,h zJ鲍]bNZ7x-5Rhu^[󵠯W,6UpG`"oSA֮`Eӂ ڮ CŜi6g`̰.x#'^J^&{Q0uVrZ u=@)-\/G**X ܬ1ap0Koi}Oٕ_zUk~O*PBɰC ʿffVw77 BLOvFd;DE=Ա+OY :xZޣQ9Ǝ>Jt9ڢ{W63jq7ev/g9?,pEn0+%zϮ+ noY`W=!^Ȏ;I5@P XAk (` 5@P XAk (` 5@P XAk (` 5@P XAk (` 5@P XAk (` 5@P XAk (` 5@P XAk (` 5@P XAk (` 5@P XAk (` 5@P XAk (` 5@P XAk (` 5@P XAk (` 5@P XAk (` 5@P XAk (` 5@P XAkd2IENDB`seriation/inst/README_files/seriation-1.png0000644000176200001440000007172514610032223020211 0ustar liggesusersPNG  IHDRHc pHYsod IDATxy\𓰉ٷH-z-DnW`+\*hA_ ↭ZA\**kE+n ,*Đy۹F$}?cr3g$ơ(tv!H!$x) <BBHR @ !H!$x) <BBHR @ !H!$x) hjjٳgtR:Zjjj?CEE=-73++,6 [7f:ޝ8?x}lտo;z{w1cgg#mJH˗~zѢEx{BaMMMMMׯ{-}͛7{-.nGNNNjjªUz$q cc㷳 pYf}G<[.B?Bf 6lx<77g϶|iݻ7}t:Zee%S1<<|ܸqjjjfffgϾ}v8>?uMMM'Mm޼2m4###SNXZZ3&$$JϧycǎBٳgϞ.mfU\x1..njjj_}UCCx_~eƌ RVV6007n%G K_~ȑ:::ӦMkg 'Neo޼ o޼YrСCutt|}}[c63f̠utt.\@ٳgzzz:::NNN"G: *tttw- ' =.tppK|8=sNYY}/RVVƍ-k+Vhg 9!yPzzzϟgL:.߸q!ۛ 1;-dVڬ1sa hfٲeLV[Ռdq]" @|)nݺ qYzuH24yy={0mݛ͢ޖ//MOzO@uo3_VAQTHH!͛7lB>; ~۶mtzHHȒ%KDc~hnܸAv(((|g/,&-^.?')**+++:&L̞=ᅬӣKn޼6]*SŜlٲرc%VVVB @;l'B&L_:;;o3]mСtg}{+W ޒdq]>qDolABի;>j(5*))1jͩS ⩺2ǛMMMlb``@;vg:UPEuBrrrY} ^ B8ΥK:[xzz%;wKT3_II!Ychh(]gtɀ!/^KSRRFMʪY;7#2fff xlf 2@L̙3EUWWhkkO6u_Vf$ED"pժUDE544хk$׮]Kund744w{%t޾]'PmE566*))BYc >|XZZJ8q|@N>}j/UUO>.S:1Z&MB!;wjjjPhaauݻw6:fDWBFzKKK___PAAakך 9rd;Hg6}fb>xQ^^^QQ^YYyܹ_tf8!!!tG0g,޸qYٳgӇEFѝmYli8e'w=>dԨQLuvvޱc7|!A}߻~2-woEEEzҥK4A=|6lx#s?د_?˗3TUUѿt:::L! Kl Fu񻴙}1A?C˶uI7b̐530444i+)qB p(ݦC='{=.YDf^'w]dZݽL7B ;gͱYfmٲ;^xAO5=x=!~@BD_ג%KFw2BHCCCVVɓ'|~v2g&OZmKΘaf_ vR'7Sbtj9rd~~~ !ӦM{q L b ;wD"/ݦ}oRDQ}ܽ:Oh8k ݓ'O%jjj 6;!DEEŋCYYYdgg3~fG8=ZUUB7eaK.]#9;;;;;s81c|'N+д OCo,}JocffKzjUUy:sof--->|ج3O裏MMM_CKKw#fJ?Orrޞ={vRWǹp႓g^^ޏ?HQWW_t){re''S^pT]]/ mKȮ^ ~~㫯0ydDB V9=' :'ӡ{=[?f5;&d\O_>PPP`Nb.jjj?̌%0׏ݿԴebcc<]6tڶ6 ̬ftuu:uD%IWCur3۹LN|mF! FnՙӬmVf$\&7}tv>ls\⊊Lwr񝹭466RO h:UPŜ?!2 C.Zti^^ʰa>{3u,--&Nill9&W1ݽ{700V]]}„ ̽h\.رcN!& <͛!!!FRQQ133|2W>}Ҳ<nϟo'>6_\\ܬsǏ{yy=:88"K:QRR:}̙3oܸ܄u֭o-ζm† 󳳳?#Vӳf277O?͜9nsA++~uDYQQ8q΄ cbb$kvu{י/T;_k艹>offFYPPVSS|'>|zjldO_ɓ.]}7,XgϞn˻=xB={5kpBBrtk\)7nܸqaAs|py 1gG.˓wa3݋AZ.XBBƎ{޽Cr\EEݻw`"}vMo߃ޅ{jhhDEEv[]8n9yׯ555{-}L}}=}%XqAݿۦf<BBHR @ !H!$x) <BBHR @ !H!$x) <BBHR @ !H!$x) <BBHR @ !H!$x) <e홙 :..[MMM,۷>EQVxyyQd#D3E6ҬSg)rm"ꩰPb)"B(}6¾|bΘOݑbŊ.X]]q?V=xjL8<[6c#,F/,Ed?%]e"Rc)2!DKF9F 6¾ƍե={Fc؃cR=x-!`ޅ<Bd E%Xw @PKHB~֭nt =xhСC#""!"ӧqqq:::4hw<'''&&&66sN. }VV``ի;nܸwG$[u}ӧK:$xh۷iyyy ?QQQ:::433KHHXx13w„ "d˖-'O'xzzZYYܹsƍV~ٳ_~-M999W(--pVXbŊV+?y򤶶v֬Y\Yp>:''g޽[eeeOOڵkF%q XT[[C[vխw䴱aJlllA?;8Нt+..r퓗.}RUUUii)}Pm6wܶ斕Bx<SIQ˗/k̛7/::zi0~muVVVz%cD&.ѣVr\9!7K :th```W[ @j!K?ƍ .9s>}z- ]fMZZZxx8!~ҤI^JHH| EfΜ9p}u֭^3͋.**ڵke-[:u*!! 0D/?~LbJܹSTTļupp044l8 ={v!ĺ";w$L6ŭY<@pJKKwܹ>2vX$o=s8!D~o1IA/Hjjj".[lӦMf3m޼y wẙ^*{{{{ ,2d!ݻLITTEQE544ɵmMM͖ZZZfffAAAtNKKc1FFFgϞu<]]]zDYYYx;\(BD"nw!K?MMMKK協\Bw[bgddTUU>=KOBLLLZF -1?@[e_}…/^w)Α#Gꔕ+>|. Z noo/''wqmYY/ҥ'ɄӧW>qĔ)S ߿{nDZ+.. zURRѣ !ɚΝTQQ! ><114**~… ?ׯ_kiiEFF<$osCH"66u۶m ;||| :dРA֭ PVV=ztvv&ೲmݺ/ڷo_``````}}Ò%K[׿PvKCH2dԩSNmVFOI&~B{xx\?LQTEEEJKKClݺBQԚ5k:}_VJdd%K=zT]]aÆOΟ?dEIp =E~wޅ ^ZZjiiu }}n@!zx9/_r8HQSS&ky_6]Bl("h ЃBHRC spZmpm6";n1="(w":MgןȮzW[vb6&N IDATVz z [(~Q.z s$f!H! ( @/CK?>t{ɓ'*BHbbN/6@`^vL4իWΝ322%Dg:xjkk=<<={vY33N.% %o,?駟,--oAEE6)))766wssSPPИ1cFUUU XWWhllllldɒ<44Ąب Őe@ yO?dmm͔-Zѣnnn ,HHH`憅Y&---<![XX466BLLL!)))~zW^_ >㦦&ť/NNN%%%tCO[YY1 5W\xtv'())3|||!_̜={6"򫯝dl>{AiӦ5kB !cǎmV@kjjY,++344/?@ׅ [[ABƏ矯_~ԩ#F/C///oztY444|xIee%3=vX==K.CkӦM7olmm233ᮮo'ѣ򦦦T>xɓ'1>,( ^A]߷o߭[֯_qƓ'O^zÆ ^^^o'ٳT:e}}}Wyyy8=tHMM=zĉVW[[lٲ{oGl]H2iҥ6mzjTTTdddJJ_VVVBBBpppw0### 믿2aUUӧ߿; xdee;88ٳGIIiܸq̉₂|ȑÇgggK:N;-^qq{w ww7k;~=BIIJ Jȁ,E~ K !zlg?Fl}yW[W[fHM[~{|՟t箝'NTRR:y$!jܹ7n Ν;BQ͘1cI;622RWW;gksrr===U+//?~...Ջ/gڵ+''gcǎ9sfxx^vvvRRR||CiV['~!`#2O]Jbv4;/b)1j,E&lVU-r|DS7g姛jBF`GJJJtt֭[Ξ=knnNϺzjJJʞ={TTTN:|򨨨?f͒`us%~~~>{ݻw獵UUU@BI΢`Tw$;) 0D2"ToUK$XW ЃYCIteEHHɓ.\=lذ8;;_riӦ 0 44t~{=/}p ^&:th۶m_|SbŊ)S|׮]r[lILLO ˗/_pa:.P(/~άvdzO(\]<BwqƍёE9;;߾}~+6n8tP555GGǏ35444f̘QUUv>|xժUzzzO>efHÇeee .l9kĉ^~~~SSg̘Ѭ€Ξ=Go7l0w!C rXXnnn5k;~袢]vԧ@(IY~w!X[[:Ν;?nlldkԪ'O$&&nݺuҥOOuyyyLMM8pƏWPP, 4GrH1EQҤ˗/;s7Bx/ƌ7o|%//?|~Y5koEE3ٳg[a@.'*壣O<'^^\\4vؿȫWn۶MNDDċ/ON?r3Æ ׯd B˯ցIvaܹW\ ̜4ivAAN<)''Gqss 9{=sLzzz``!O?]jUCCmjjjFFFzzĭ@qqq|>׮];w|KuuuNBB„ ֯_/ >c[RR2dȐ >ߝVx@q>79^^^Z8FXڽ/X+"/RdBOȊ,>DnUt\j_U}wW*333_[xCW,AOB!bH!$x)c k( O#H!@Pu}yH!$x)!z9"Qc#H t2W^˳7_|RdBGy>K !&FXSl}][0D Ѓ#q<>$x)!z-F{zR=x1%Ic<4BBHfڵ}566޶m[h$!DUUu޽)((viW_ ॑Brr2=oEGGֽ3jԩٲeKmmmZZi4ABrrr%sνx񢛛[7 BymA  #F TWWo[[[ۤ$"hڵUUUtq||ƌ3Y _|񅹹ٳ;zC4coݺ񴵵}||JJJ!cƌ9x`zz:yK &JDIVw Ls!ёh"OOϣG-X !!y⤤ǏGDD0tuusss׬YNϘ1c|MyyԶI&z*!!!22 , dee 4i!z)t1fѣGс&&&uuuaaau8@qrr_n޼Ʉ555=p?~|^^^AA!ʕ+ǎ"xyy yiӦM6M$ oUNׯ%~311EBƎsBjjje-ijj,? K Z--\33 {{{6}H,88/--wyy9 FWf-:kO>/)++k+oD3UUU?߿ߙM$y."xVII)33*q#GVUUeeeoBajj*3>|~ ZF8r䈕U]][BB}Mc2B]]RQQaccTZZjoo+qdwwѣGϞ={Æ &&&  Ç'&&FEE=e;; W^%%%ikk=PTTtu;;;999 Ѓ C p8_5!$***222%%/+++!!!88;O>=mڴ%K_o߾AN0>ѯA,]T^^>;;>?o޼ׯ_;;;u(BD"I^ݗ:zh '"oqttTUU *;.111,,)(bo%^^^VC&;|Fpy6OVcg`)2OM_Q*,ERdB0VK{nu]5Ϊ>avu?sr--++N8q޽yyywޥ`aÆk._|ĉ111}N=ٲeɓ !VVV;wܸqx@eڛ7obbbvH%ׯ6Htn xWWWo===[>ɓ'/_:u*S2f̘?|Ĕ?^YYY_ˇࡇ)++sد}ǔhjjRdaaD=tP\\.(~@PDTW_B.K?ȣ͕R;%mY7oޜ9s̙)f$;)I|=,z())'N?Jzzď@d %I^ӈ344p8<`JZ}ߊ/|"D#%%%::z֭gϞ577g]z5%%eϞ=EEEݻ1D]|&;;Ύ)߽{7EQ***/ZC%HRC k(c,һЃBw:=x) c/^FFFʖ+Wlٱc=wޞh&@K[Νsrr 111G]hѡC>ÆԩSMMM{$0pt`ӦMvvvYYYS===:`ONN~h=xGN1bDhhɓ W^ 4HYYbÆ Ïx}'&~999g ###=<<ŋo۶-88oycII !O>>׮]$XZ1cFLLÇ znQQQRRݻ,Y2k֬~A B8NTTԊ+|~llUAAA`hCx<^JJJMMMnnO?t餤$ssSN <ҥK\.wteϟ+((B=J}?~,_tE}n=x@SS!DCC;..gΜ !OQUU~G陚$XZ),,?wx۷ !zzzUUU삂TWW;;;7?bGFF7B0 @(*((WUUEFF|Ν;ZZZk]]ڂp׾/^8s挡nݺqư/n߾I(DcGikbtttttt򀀀yLauuug.A@ :x ]H!$x)!z-ED]mM zR=x99vH#Agو\FXK_վa)G}"B|=sm"B?Tg)۰  d E$9@CBCIrQ;!zuHRC s$M_S-z sE>oddliirʗ/_v3fAAkP"$nx`t9WWטUU۷oƞ9sI~g-[֦`S$xhӦM첲\.!СC ,xkGAA᭭@ `#555:Fj``@D7n:tǙʇbΟ?Bƌst Bȷ~ࠢbkk,UV=}BEuAz8::䄆޿DFFzxx6l;wnrr!C|~FFF1|}}-ZyQ77 $$$0vڥH1 Cbcccbb6mdbbHyIbb֭[.]J,//_nW;1555tuu"""!uuu֭ + 4HM</%%"--+??? 7n3f0g̘qM@...qrr*///))+xxx @D.B$''M 9qӧO\"Ĥ3񋋋 !cǎmV^SScllL<Ѓ˟;wNt^QQ}O:::r 6 ~~t ~@uZZZ;v;,%\2rHB#G6l}<}!] .\Rff&SE$M_;C:%%y7,..NNN&駫VjhhMMMHOO>|xbbiTTϙ EEEׯ_ *--ɉ .H& ?q׮][RR2dȐ bwBȾ},YBq'̛7/77ɓ'QQQ:::433KHHXxql,J66oFNNnڵk׮m9(Q &<~ybŊ+VPZZڍ: Lf% IDATu dDO!ѣGkhhL8HoCVVÞ={ƍ׫%Hf͚#/////Ȩ;ker [tUI$}mU>}|ܲ2BcJ455)z򥶶v[ Hp8Goddliirʗ/_2s ]֋/Ν;z3g\|~F-[jkkzeHkӦMvvvYYY\.nggwС 6ByyVQ4Ip]_;CѣGjjjtv1"442f̘s8/^B[[[ۤ$z{{{&EQFFF}E!nnn 3f̨gݺuݝikk1H'$x蘓z}022Ã^VVh"OOϣG-X !!w & _|?3g!Ehaaak֬IKK 'O4իW /_~kc R+661&&fӦM&&&...ފMMMee妦&]]ݺ0BG]]ݺu낂NdBHjj1cY^8 !wy١C\\\!$У/x<^JJJEEEZZW~~~@@,,,tqqSyyyII[FF]355]ÃϣK!fff˖-ۿiiiӢ ]eS544Δ<رctEr++:eee77~;[ pRRRJHH7o޸q ?~dBQQBBBJKKsrrbbbbcch~~~o޼9s&]"+.. zURRѣY@6Q4u[/-,,GG]v1uvv~ITT###/^̄ rqqc _U JMM]n]@@ѣ[=ZPT;I^^^"%;sKVMl]LX~C `)2!R䭻n=K!a˧y>}FwGff7 VY+ hЃOBBBQ=M<BB"Xh ЃB4ؿFdyyCI?URdl}Z !ֳymXL Y4c%FJ&nU<BBBq<>$x)!z-,z ]H!$x)/9mظq#!x۶mLPIW ˨+V̜9^lɲeCv@@Qu댍}}}{=oaׯiVa$֮]kaa_UUŔoܸqСjjjǏg166;vEBBBii)xfff=]իW!!! RVVذa$nݺ񴵵}||JJJVH$xh͛"""?AoذaܹC RWvss2dg}6zh^WWwO> <|0_vmJJ !~ҤI^JHH| ze: C8@qrr_n޼IyIbb֭[.]J,//_n7}}}CBB!"hԩŶ'**jń>ԩ>Ν;Ϟ=;t萋 !DWW7??E2p<MMMGBjkk>|xwq1?-J˗=j ʭ+!XbB-.Z"DRJWfwd|Q39ӾΧ|>ݻ7Z@=hfۃRRRZZZ#|>|ح[7'~+SBBD{^l)z+`0$yyyHii)._VUU5nܸQF}6%%E___𬅅Ebbbee+W8Nnn.Z_O6<{H\\eddeBVVVss?7AccׯɧΞ=khhX__/++;a„CxW^QUăkcՍ JHHHLLr>a,kޕ۶myIEEYAA3-[V[[{1 KKK@GY<xutt=ZTTdll^zEGGo޼$007<<<(((!!a˖-3f̐LKKSSSkI4@LB kkDX7ǒ;3XPPԄn}q:sDV]UBSrS#]㮭VuPc}#M%%4%#h XFKlS -Q*g3VUrG.UUU555 jjj444z0x ΞH8{:=- mٝLfy<&L'Ϟ=gɶr›xGZI!(@bٳgϞ== @biio^mmmЇG>|fS c0ϟ?ѣ}gNMMmܸq7[ZZMFmٲt6oތb27naoNNNׯ_ӧ}b  @P @P @P @P @P @PAƎHgA7W<3bW_PASRR:z _-,,X!***eee޿gϞt~[dZYY)FɠӂbAWjժ/^?`P… w.rJMMѣ̙3m4555 ߐ!rdddkhh9AO~|ɟYQQL+!TTTh"SSӝ;w;wn<OCC#--Դs&qtuqqq;wlnnvpp֖ߴNߡCxA>|#ŋɴ~C~g BW^%_@\@.={ou8 Q[[# ٳK.QR7AܻwOOOlmm-9M,--[\x5~70\YYyʕ(^!6mQon]|||cEEq%SWW'rOw~ȑ)SP7XC^~bll˗/s8~suuu[n۷/˭1cFiiݻw1iB+TYYiӦl?'1̎ێfOsСCMMM׮]gϞ}Btұc666 888xzzb&oݺUFF&<<痔8p@FF&883Da3g> !BII),, ?-q"<<\]]]W/^n5rZ}&{]]]db &"3˗`&/^!MMM Jي6)zǏ 455;/xM#da!%%uuݿXWW s~Lӧzʕ^!JJJ8,cƌjmhjjRtrtuaaaf͢i73xxxL4<<99©Ϣ+((h;wPϟsܘEEź:mm;v|T"##Ʀ-˗,XPRR" 'YZZ:##e_  ?ؿ?N2!}]9"~E}v g)zPVV='Ottt\]]ccc͛m۶;88Zc%YYYU111 .tww=zyB#Fa"Һ!tرVGY۷oc&ׅY~כ`)x={yF__ܪdĈߤ:EEc~mSZyETT70mbbboogk֬tRNNN2}CɬF߾}]\\{ȑ'''fӦM}-f?G,ۖM 999kkObɥ%%%E^^3GpݎǏb}]&N8l0(~NNNL AWm6Ϯr֭-?~; uݨY +++߲̎ lllȳDs<|eAAyԩS1Áx0x:::[[p+**nݺpݺ:bimNf5UUU### 2d_xpxk:t#"" 3 I.::dzxxDGG2(d?7HQQQٱc&WTTXbȑmP2lTWW(y&ba&Ǵe˖ݻP1p~}qvv~YK t~tur ZzyzQ\\o>Hp85ٹs'~QUUEU_V-nBRRRC 9v옑f8\rrq𣀘:yyxGGG%SWW<`WWװ0k׮MIIӁV6+222]/**:/^8c ===FXbܹÇ}̝;wΜ9>}u?~ lC>`0uVXAoNHHHHHxСC->EF66@\@߿?((HДfm۶MAgcIDAT͚5k„ %%%gΜMNNn5a &imt1e.\XbEg͚%|ʕ+sSD''3ft޽4...111))IW/%߿OV<;;T Ati<UN;Z;ίW^~~~߿}bdCCC__e˖ ڵkW^^NՠA=*|pɒ%=v˗/_p!>>X:,aUUU(|/vܹ9ߘRbbŋ{@gϒmy<^bbի1.^`jj"f2,kĉ?sYY~2533#[/3!Cp\X .`lɓ'0; :/77իWl<:eʔ :/,,իW'OVSS-..ܷof͛g̘!%%QYYpBBB0{ѣV srr0YXXܿfO0!**EUU?!/Ji=vLn'ӌNrQQѢELMMwyܹӧx< 4 iHoMۙZZZn 6lȐ!۶m >}VYYY||U6n>eʔiӦM4III ¾ٕiA]`u[޽IvsssNDDC<==mQpi֔ >"%%ևn?٭p(**ƶx|2é,3]wرdɒw^z>>>eee=vΏO:Kޛc c͛ꚙQ2?O| JJJBAٹ:8p ֮]+|p׮]ǎc 5xyT鍢"%!ɓM6:8mڴ3gĒ<==ۻ}_4555G~?}PYY9eʔ;wX[[矔xr\Vbbb.\>zy!Ff=<}3g?~_RRr`䦦&PFF%$/44Tp< 700-\~z {`ccc999JjpOII'(11122211L ..jĉ믿޾};g5sLs8p Y***ȇqqqϟ?ǏR ΏlvrraϞ=ccceeeEKun@b ֭[ 8wYXX BCCO:%xҤIqqqg#xp3B,tt:puXSF굵ǹEEEg߼y#v.\Иڿ2\ZZzΜ9% `2dryyyRRRHHȎ;0+++D^a֮]*x[ђ-X6(((00e`ɒ%ǔ4V <=ma +ƅQ^)I999=l7er]>1۸q1coܸ1c ov}~7 ֠  &0==]=zAo¨vaOOݻw/YDAAApӧOAAA۷o?q1. ?~f3\07pi߹Lsss³~Gupph?//!??_# O<xE7?ƍ8޽{)tP?Oɵmeff>\BSNm޽{1)Kkk}x<&~!%ٻwFL:UxBb͟?F~燆 455Canxлwo:FĦMBBB"##E뀦g &:8nܸW^8hРzEK6{ÇHƣG^t|訯*ڟhٳg7Mdddtmr4~|rWWÇ/YS?SRRf3 G#' Ȉ1=zW^vvvv\h"̳PرcO>/_9sݻK.>}ȣݵkcU^^vuw*AAAeeed<.[PPfkk4f̘И&swIAAlk>JN.]f֭ü[͛#F :tիW)0o+Ev7ow5tP̳x|g``@:C9nS222ΝȇwAs3g,\Ad1r/'oK]]۷ooݺ%|\WWWecƌ~z޽ɇ򖖖;vtx7o|iMMM߾}'Opnݺ )ZVWWHB@|vĉ .={ku`0E𡙙Bo߾#G+,::dzxx d0QQQ "kii3::oollLMMWX^^^nnnSHsssHHׯuuu8pkׄiiiUWW㌜dllG}իW4?\dff2aÆ?`6Ș>}̽{DK@1___ oߒჶsp򫪪rrrx(wUWWߺuK ya^vmnn544o(m۩SVWW} &={V޾OI,@L@5kdff|Aܹ3##mwX,Jxzz^~]kE]&.uuuW\+,,$op8eee&M ޮ]6l`bbxbCCC))O:u?ݻwoG|||/^lddDDnnÇSSSƈӧ+˖-[tsaa!y`{ <sҥK߿/8ҿPSVZE#ikkڵkܹ8'OܷoǏ}||ԔMLL屇(۷ XMM󯴴x)iGjժ5k֐֮][PPӐeML& ˅';BuV-oWC5@$x@"; xfcG  !;x@5x@A$x@A$x@A$x@A$x@A$x@A$x@A$x@A$x@A$x@A$x@A$x@A$x@A$x@A$x@A$x@A$x@A$x@A$x@A$kbaIENDB`seriation/inst/CITATION0000644000176200001440000000205414372451062014366 0ustar liggesusers citation(auto = meta) bibentry(bibtype = "article", title = paste("Getting things in order: ", "An introduction to the R package seriation"), author = { c(person("Michael", "Hahsler", email = "mhahsler@lyle.smu.edu", comment = c(ORCID = "0000-0003-2716-1405")), person("Kurt", "Hornik", email = "Kurt.Hornik@R-project.org", comment = c(ORCID = "0000-0003-4198-9911")), person("Christian", "Buchta", email = "Christian.Buchta@wu.ac.at")) }, year = 2008, journal = "Journal of Statistical Software", volume = 25, number = 3, pages = "1--34", doi = "10.18637/jss.v025.i03", month = "March", issn = "1548-7660" ) bibentry(bibtype = "article", title = "An experimental comparison of seriation methods for one-mode two-way data", author = person("Michael", "Hahsler", email = "mhahsler@lyle.smu.edu"), year = 2017, journal = "European Journal of Operational Research", volume = 257, number = 1, pages = "133--143", doi = "10.1016/j.ejor.2016.08.066", month = "February" )