From 9e0526a8482e451045b6690d9da877259b7bd433 Mon Sep 17 00:00:00 2001 From: Jari Oksanen Date: Tue, 19 Mar 2024 17:50:02 +0000 Subject: [PATCH] version 1.3-0 --- DESCRIPTION | 10 +- MD5 | 18 +- NAMESPACE | 10 +- R/orditkplot.R | 615 +++++++++++++++++++++++++++++++++++++++++ R/plot.orditkplot.R | 14 + R/points.orditkplot.R | 5 + R/scores.orditkplot.R | 9 + R/text.orditkplot.R | 9 + build/partial.rdb | Bin 6323 -> 7038 bytes inst/NEWS.md | 15 + inst/README.md | 7 + man/orditkplot.Rd | 172 ++++++++++++ man/vegan3d-package.Rd | 21 +- 13 files changed, 891 insertions(+), 14 deletions(-) create mode 100644 R/orditkplot.R create mode 100644 R/plot.orditkplot.R create mode 100644 R/points.orditkplot.R create mode 100644 R/scores.orditkplot.R create mode 100644 R/text.orditkplot.R create mode 100644 man/orditkplot.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 6ab4ac3..15d67f7 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,7 @@ Package: vegan3d -Title: Static and Dynamic 3D Plots for the 'vegan' Package -Version: 1.2-0 +Title: Static and Dynamic 3D and Editable Interactive Plots for the + 'vegan' Package +Version: 1.3-0 Authors@R: c(person("Jari", "Oksanen", role=c("aut","cre"), email="jhoksane@gmail.com"), person("Roeland", "Kindt", role="aut"), @@ -9,6 +10,7 @@ Authors@R: c(person("Jari", "Oksanen", role=c("aut","cre"), person("Duncan", "Murdoch", role="ctb", email="murdoch.duncan@gmail.com")) Depends: R (>= 3.2.0), vegan (>= 2.3-0) +Suggests: tcltk Imports: cluster, rgl, scatterplot3d (>= 0.3-40) Description: Static and dynamic 3D plots to be used with ordination results and in diversity analysis, especially with the vegan package. @@ -16,11 +18,11 @@ License: GPL-2 BugReports: https://github.com/vegandevs/vegan3d/issues URL: https://cran.r-project.org/, https://github.com/vegandevs/vegan3d NeedsCompilation: no -Packaged: 2023-02-03 09:35:55 UTC; jarioksa +Packaged: 2024-03-19 16:52:25 UTC; jarioksa Author: Jari Oksanen [aut, cre], Roeland Kindt [aut], Gavin L. Simpson [aut], Duncan Murdoch [ctb] Maintainer: Jari Oksanen Repository: CRAN -Date/Publication: 2023-02-03 11:50:02 UTC +Date/Publication: 2024-03-19 17:50:02 UTC diff --git a/MD5 b/MD5 index 1b0568e..d2bf6a9 100644 --- a/MD5 +++ b/MD5 @@ -1,7 +1,8 @@ -ebd205452b86d799977d97fa7918d5a0 *DESCRIPTION -0c2dc97c114f6e8743c5df4e4f3d9d2f *NAMESPACE +54dbdc86641e7ea9aefb1113ae424d08 *DESCRIPTION +adaea026f1eb4e41bfd0f3bbd38c1169 *NAMESPACE 70ff7e72e6ee74c5203c907708a8331b *R/ordiplot3d.R 11c71e922f8d88b49ea555e0e37ac8c5 *R/ordirgl.R +908855581b1576889a36f3b60aa79c09 *R/orditkplot.R 248167fa58583dca110f246f53d14da0 *R/orditree3d.R d696ba823b3b2cff10bff48847a6533c *R/orglellipse.R cb1b31410739cb62ffce848c84a1ed77 *R/orglpoints.R @@ -9,15 +10,20 @@ f1e80940be7c736252a21bac17450377 *R/orglsegments.R 1460de3de45054d5f753d1ed7d2eac91 *R/orglspantree.R 89509d45f20dcc42e240f0e2085411f0 *R/orglspider.R 068180bb164e74cb5c66d149f25826c6 *R/orgltext.R +da30b6ae5fd0e30543f18064cf19b54a *R/plot.orditkplot.R +e0ff3ea4aa76f85a87c3d8f559df18f0 *R/points.orditkplot.R c862222b3f0202d15b646f6c48233541 *R/rgl.isomap.R 9ffe3b7c76b8e4acd2751ab611ab20a3 *R/rgl.renyiaccum.R 459f34914f0416645498dc434a961e94 *R/scores.ordiplot3d.R -90886d58ab24aa32b5a1d5bb0d2b1228 *build/partial.rdb -c031ef9720009151e87ce2c6a0cde642 *inst/NEWS.md -f395748ce7a81a29e7b9488a537fcaf8 *inst/README.md +512cedf50891372019cae370b240a742 *R/scores.orditkplot.R +dbc282f5aef3c9729d098b4fb80004b7 *R/text.orditkplot.R +d655824677a5b34f23b6bbc268a96947 *build/partial.rdb +7ae7daadb65140568ade8fa5cd783d00 *inst/NEWS.md +ffe7f18493aaee318b57ef2dd1cac40c *inst/README.md 104d528326300a6e9ea69ec1c2e4230d *man/ordiplot3d.Rd 8ed20ef58af1495ddded97ec3b9b7e46 *man/ordirgl.Rd +94d8d06a4d1ce47a7521eb6d23c92b16 *man/orditkplot.Rd 59712b4f9896bb6a7f7da897c920be05 *man/orditree3d.Rd 8c4d39f1f5fa8961f2078b7057cc9c29 *man/rgl.isomap.Rd 146da10b606c2e6c5ccdbca4f684659a *man/rgl.renyiaccum.Rd -a943fc187ad411d7b5db7a45646e53cf *man/vegan3d-package.Rd +29ce86a370cf5d821fc65edd39d19458 *man/vegan3d-package.Rd diff --git a/NAMESPACE b/NAMESPACE index 3a77a5e..45561cb 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -7,8 +7,9 @@ import(scatterplot3d) ## ellipsoid hulls importFrom(cluster, ellipsoidhull) ## explicit imports for base R functions -importFrom(grDevices, rainbow, col2rgb, rgb) -importFrom(graphics, arrows, points, segments, text) +importFrom(grDevices, rainbow, col2rgb, rgb, bmp, check.options, dev.off, + jpeg, palette, pdf, png, postscript, svg, tiff, xfig) +importFrom(graphics, arrows, par, points, segments, text) importFrom(stats, weighted.mean, weights, as.hclust, reorder, cov.wt, qchisq) ## export what we got @@ -16,6 +17,7 @@ export(orditree3d, ordiplot3d, ordirgl, ordirgltree, + orditkplot, orglcluster, orglellipse, orglpoints, @@ -27,3 +29,7 @@ export(orditree3d, rgl.renyiaccum) ## S3 methods S3method(scores, ordiplot3d) +S3method(plot, orditkplot) +S3method(points, orditkplot) +S3method(scores, orditkplot) +S3method(text, orditkplot) diff --git a/R/orditkplot.R b/R/orditkplot.R new file mode 100644 index 0000000..f76d06d --- /dev/null +++ b/R/orditkplot.R @@ -0,0 +1,615 @@ +### This function was a part of vegan package from 2008 (release +### 1.11-0) to 2023 (release 2.6-4) when it was moved vegan3d due to +### its exotic dependencies (Tcl/Tk). Development was mainly done in +### 2008 to 2015 and mostly in 2008. Some obvious changes to be made +### are: + +### * Enable several sets ("layers") of scores. Currently the only +### practical way is to base editing on ordipointlabel results (see +### Examples in doc). + +### * Enable reading of new sets of scores ("layers") from the Tcl/Tk +### window, even launching an empty window and reading all scores from +### the GUI. + +### * Handle arrows, such as CCA and envfit. + +### * Enable setting graphical par() per set of scores ("layers"). + +### +### Editable Tcl/Tk plot for ordination +### +`orditkplot` <- + function(x, display = "species", choices = 1:2, width, xlim, ylim, + tcex=0.8, tcol, pch = 1, pcol, pbg, pcex = 0.7, + labels, ...) +{ + if (!capabilities("tcltk")) + stop("your R has no capability for Tcl/Tk") + requireNamespace("tcltk") || stop("requires package tcltk") + +############################ +### Check and sanitize input +########################### + + ## Graphical parameters and constants, and save some for later plotting + p <- par() + sparnam <- c("bg","cex", "cex.axis","cex.lab","col", "col.axis", "col.lab", + "family", "fg", "font", "font.axis", "font.lab", "lheight", + "lwd", "mar", "mex", "mgp", "ps", "tcl", "las") + ## Get par given in the command line and put them to p + if (inherits(x, "orditkplot")) { + dots <- x$par + for (arg in names(x$args)) + assign(arg, unlist(x$args[arg])) + } else { + dots <- match.call(expand.dots = FALSE)$... + } + if (length(dots) > 0) { + dots <- dots[names(dots) %in% sparnam] + ## eval() or mar=c(4,4,1,1) will be a call, not numeric + dots <- lapply(dots, function(x) if (is.call(x)) eval(x) else x) + p <- check.options(new = dots, name.opt = "p", + envir = environment()) + } + savepar <- p[sparnam] + PPI <- 72 # Points per Inch + p2p <- as.numeric(tcltk::tclvalue(tcltk::tcl("tk", "scaling"))) # Pixel per point + DIAM <- 2.7 # diam of plotting symbol + ## Plotting symbol diam + diam <- round(pcex * DIAM * p2p, 1) + ## Sanitize colours + sanecol <- function(x) { + if (is.numeric(x)) + x <- palette()[x] + x <- gsub("transparent", "", x) + x[is.na(x)] <- "" + x + } + p$bg <- sanecol(p$bg) + p$fg <- sanecol(p$fg) + p$col <- sanecol(p$col) + p$col.axis <- sanecol(p$col.axis) + p$col.lab <- sanecol(p$col.lab) + ## Point and label colours + if (missing(pcol)) + pcol <- p$col + if (missing(pbg)) + pbg <- "transparent" + if (missing(tcol)) + tcol <- p$col + pcol <- sanecol(pcol) + pbg <- sanecol(pbg) + tcol <- sanecol(tcol) + ## Define fonts + idx <- match(p$family, c("","serif","sans","mono")) + if (!is.na(idx)) + p$family <- c("Helvetica", "Times", "Helvetica", "Courier")[idx] + saneslant <- function(x) { + list("roman", "bold", "italic", c("bold", "italic"))[[x]] + } + ## fnt must be done later, since family, font and size can be + ## vectors and slant can be of length 1 or 2 + ## fnt <- c(p$family, round(p$ps*p$cex*tcex), saneslant(p$font)) + labfam <- p$family + labsize <- round(p$ps * p$cex * tcex) + fnt.axis <- c(p$family, round(p$ps*p$cex.axis), saneslant(p$font.axis)) + fnt.lab <- c(p$family, round(p$ps*p$cex.lab), saneslant(p$font.lab)) + ## Imitate R plotting symbols pch + SQ <- sqrt(2) # Scaling factor for plot + Point <- function(x, y, pch, col, fill, diam) { + x <- round(x) + y <- round(y) + switch(as.character(pch), + "0" = Point(x, y, 22, col, fill = "", diam), + "1" = Point(x, y, 21, col, fill = "", diam), + "2" = Point(x, y, 24, col, fill = "", diam), + "3" = {tcltk::tkcreate(can, "line", + x, y+SQ*diam, x, y-SQ*diam, fill=col) + tcltk::tkcreate(can, "line", + x+SQ*diam, y, x-SQ*diam, y, fill=col)}, + "4" = {tcltk::tkcreate(can, "line", + x-diam, y-diam, x+diam, y+diam, fill=col) + tcltk::tkcreate(can, "line", + x-diam, y+diam, x+diam, y-diam, fill=col)}, + "5" = Point(x, y, 23, col, fill = "", diam), + "6" = Point(x, y, 25, col, fill = "", diam), + "7" = {Point(x, y, 4, col, fill, diam) + Point(x, y, 0, col, fill, diam)}, + "8" = {Point(x, y, 3, col, fill, diam) + Point(x, y, 4, col, fill, diam)}, + "9" = {Point(x, y, 3, col, fill, diam) + Point(x, y, 5, col, fill, diam)}, + "10" = {Point(x, y, 3, col, fill, diam/SQ) + Point(x, y, 1, col, fill, diam)}, + "11" = {Point(x, y, 2, col, fill, diam) + Point(x, y, 6, col, fill, diam)}, + "12" = {Point(x, y, 3, col, fill, diam/SQ) + Point(x, y, 0, col, fill, diam)}, + "13" = {Point(x, y, 4, col, fill, diam) + Point(x, y, 1, col, fill, diam)}, + "14" = {tcltk::tkcreate(can, "line", x-diam, y-diam, x, y+diam, + fill = col) + tcltk::tkcreate(can, "line", x+diam, y-diam, x, y+diam, + fill = col) + Point(x, y, 0, col, fill, diam)}, + "15" = Point(x, y, 22, col = col, fill = col, diam), + "16" = Point(x, y, 21, col = col, fill = col, diam), + "17" = Point(x, y, 24, col = col, fill = col, diam), + "18" = Point(x, y, 23, col = col, fill = col, diam/SQ), + "19" = Point(x, y, 21, col = col, fill = col, diam), + "20" = Point(x, y, 21, col = col, fill = col, diam/2), + "21" = tcltk::tkcreate(can, "oval", x-diam, y-diam, + x+diam, y+diam, outline = col, fill = fill), + "22" = tcltk::tkcreate(can, "rectangle", x-diam, y-diam, + x+diam, y+diam, outline = col, fill = fill), + "23" = tcltk::tkcreate(can, "polygon", x, y+SQ*diam, + x+SQ*diam, y, x, y-SQ*diam, x-SQ*diam, y, + outline = col, fill = fill), + "24" = tcltk::tkcreate(can, "polygon", x, y-SQ*diam, + x+sqrt(6)/2*diam, y+SQ/2*diam, x-sqrt(6)/2*diam, y+SQ/2*diam, + outline = col, fill = fill), + "25" = tcltk::tkcreate(can, "polygon", x, y+SQ*diam, + x+sqrt(6)/2*diam, y-SQ/2*diam, x-sqrt(6)/2*diam, y-SQ/2*diam, + outline = col, fill = fill), + "o" = Point(x, y, 1, col, fill, diam), + ## default: text with dummy location of the label + {tcltk::tkcreate(can, "text", + x, y, text = as.character(pch), fill = col) + Point(x, y, 21, col="", fill="", diam)} + ) + } + +############################ +### Initialize Tcl/Tk Window +############################ + + ## toplevel + w <- tcltk::tktoplevel() + tcltk::tktitle(w) <- deparse(match.call()) + ## Max dim of windows (depends on screen) + YSCR <- as.numeric(tcltk::tkwinfo("screenheight", w)) - 150 + XSCR <- as.numeric(tcltk::tkwinfo("screenwidth", w)) + +################################ +### Buttons and button functions +################################ + + ## Buttons + buts <- tcltk::tkframe(w) + ## Copy current canvas to EPS using the standard Tcl/Tk utility + cp2eps <- tcltk::tkbutton(buts, text="Copy to EPS", + command=function() tcltk::tkpostscript(can, x=0, y=0, + height=height, width=width, + file=tcltk::tkgetSaveFile( + filetypes="{{EPS file} {.eps}}", + defaultextension=".eps"))) + dismiss <- tcltk::tkbutton(buts, text="Close", + command=function() tcltk::tkdestroy(w)) + ## Dump current plot to an "orditkplot" object (internally) + ordDump <- function() { + xy <- matrix(0, nrow=nrow(sco), ncol=2) + rownames(xy) <- rownames(sco) + colnames(xy) <- colnames(sco) + for(nm in names(pola)) { + xy[as.numeric(tcltk::tclvalue(id[[nm]])),] <- xy2usr(nm) + } + curdim <- round(c(width, height) /PPI/p2p, 2) + ## Sanitize colours for R plot + pbg[pbg == ""] <- "transparent" + pcol[pcol == ""] <- "transparent" + ## Reduce vector args if all entries are constant + argcollapse <- function(x) + if (length(unique(x)) == 1) x[1] else x + pch <- argcollapse(pch) + pcol <- argcollapse(pcol) + pbg <- argcollapse(pbg) + tcol <- argcollapse(tcol) + ## Save + args <- list(tcex = tcex, tcol = tcol, pch = pch, pcol = pcol, + pbg = pbg, pcex = pcex, xlim = xlim, ylim = ylim) + xy <- list(labels = xy, points = sco, par = savepar, args = args, + dim = curdim) + class(xy) <- "orditkplot" + xy + } + ## Button to dump "orditkplot" object to the R session + pDump <- function() { + xy <- ordDump() + dumpVar <- tcltk::tclVar("") + tt <- tcltk::tktoplevel() + tcltk::tktitle(tt) <- "R Dump" + entryDump <- tcltk::tkentry(tt, width=20, textvariable=dumpVar) + tcltk::tkgrid(tcltk::tklabel(tt, text="Enter name for an R object")) + tcltk::tkgrid(entryDump, pady="5m") + isDone <- function() { + dumpName <- tcltk::tclvalue(dumpVar) + if (exists(dumpName, envir = parent.frame())) { + ok <- tcltk::tkmessageBox(message=paste(sQuote(dumpName), + "exists.\nOK to overwrite?"), + icon="warning", type="okcancel", + default="ok") + if(tcltk::tclvalue(ok) == "ok") { + assign(dumpName, xy, envir = parent.frame()) + tcltk::tkdestroy(tt) + } + } + else { + assign(dumpName, xy, envir = parent.frame()) + tcltk::tkdestroy(tt) + } + } + tcltk::tkbind(entryDump, "", isDone) + tcltk::tkfocus(tt) + } + dump <- tcltk::tkbutton(buts, text="Save to R", command=pDump) + ## Button to write current "orditkplot" object to a graphical device + devDump <- function() { + xy <- ordDump() + ftypes <- c("eps" = "{EPS File} {.eps}", + "pdf" = "{PDF File} {.pdf}", + "svg" = "{SVG File} {.svg}", + "png" = "{PNG File} {.png}", + "jpg" = "{JPEG File} {.jpg .jpeg}", + "bmp" = "{BMP File} {.bmp}", + "tiff"= "{TIFF File} {.tif .tiff}", + "fig" = "{XFig File} {.fig}") + falt <- rep(TRUE, length(ftypes)) + names(falt) <- names(ftypes) + if (!capabilities("png")) + falt["png"] <- FALSE + if (!capabilities("jpeg")) + falt["jpg"] <- FALSE + if (!capabilities("cairo")) + falt["svg"] <- FALSE + ## Should work also in R < 2.8.0 with no capabilities("tiff") + if (!isTRUE(unname(capabilities("tiff")))) + falt["tiff"] <- FALSE + ftypes <- ftypes[falt] + ## External Tcl/Tk in Windows seems to buggy with type + ## extensions of the file name: the extension is not + ## automatically appended, but defaultextension is interpreted + ## wrongly so that its value is not used as extension but + ## correct appending is done if defaultextension has any + ## value. The following kluge is against Tcl/Tk documentation, + ## and should be corrected if Tcl/Tk is fixed. + if (.Platform$OS.type == "windows") + fname <- tcltk::tkgetSaveFile(filetypes=ftypes, + defaultextension = TRUE) + else + fname <- tcltk::tkgetSaveFile(filetypes=ftypes) + if(tcltk::tclvalue(fname) == "") + return(NULL) + fname <- tcltk::tclvalue(fname) + ftype <- unlist(strsplit(fname, "\\.")) + ftype <- ftype[length(ftype)] + if (ftype == "jpeg") + ftype <- "jpg" + if (ftype == "tif") + ftype <- "tiff" + mess <- "is not a supported type: file not produced. Supported types are" + if (!(ftype %in% names(ftypes))) { + tcltk::tkmessageBox(message=paste(sQuote(ftype), mess, paste(names(ftypes), + collapse=", ")), icon="warning") + return(NULL) + } + pixdim <- round(xy$dim*PPI*p2p) + switch(ftype, + eps = postscript(file=fname, width=xy$dim[1], height=xy$dim[2], + paper="special", horizontal = FALSE), + pdf = pdf(file=fname, width=xy$dim[1], height=xy$dim[2]), + svg = svg(filename=fname, width=xy$dim[1], height=xy$dim[2]), + png = png(filename=fname, width=pixdim[1], height=pixdim[2]), + jpg = jpeg(filename=fname, width=pixdim[1], height=pixdim[2], + quality = 100), + tiff = tiff(filename=fname, width=pixdim[1], height=pixdim[2]), + bmp = bmp(filename=fname, width=pixdim[1], height=pixdim[2]), + fig = xfig(file=fname, width=xy$dim[1], height=xy$dim[2])) + plot.orditkplot(xy) + dev.off() + } + export <- tcltk::tkbutton(buts, text="Export plot", command=devDump) + +########## +### Canvas +########## + + ## Make canvas + sco <- try(scores(x, display=display, choices = choices, ...), + silent = TRUE) + if (inherits(sco, "try-error")) { + tcltk::tkmessageBox(message=paste("No ordination scores were found in", + sQuote(deparse(substitute(x)))), icon="error") + tcltk::tkdestroy(w) + stop("argument x did not contain ordination scores") + } + if (!missing(labels)) + rownames(sco) <- labels + ## Recycle graphical parameters in plots + nr <- nrow(sco) + pcol <- rep(pcol, length=nr) + pbg <- rep(pbg, length=nr) + pch <- rep(pch, length=nr) + tcol <- rep(tcol, length=nr) + diam <- rep(diam, length=nr) + labfam <- rep(labfam, length=nr) + labsize <- rep(labsize, length=nr) + if (inherits(x, "ordipointlabel")) + labfnt <- attr(x$labels, "font") + else + labfnt <- rep(p$font, length=nr) + ## Select only items within xlim, ylim + take <- rep(TRUE, nr) + if (!missing(xlim)) + take <- take & sco[,1] >= xlim[1] & sco[,1] <= xlim[2] + if (!missing(ylim)) + take <- take & sco[,2] >= ylim[1] & sco[,2] <= ylim[2] + sco <- sco[take,, drop=FALSE] + labs <- rownames(sco) + pcol <- pcol[take] + pbg <- pbg[take] + tcol <- tcol[take] + pch <- pch[take] + diam <- diam[take] + labfam <- labfam[take] + labsize <- labsize[take] + labfnt <- labfnt[take] + ## Ranges and pretty values for axes + if (missing(xlim)) + xlim <- range(sco[,1], na.rm = TRUE) + if (missing(ylim)) + ylim <- range(sco[,2], na.rm = TRUE) + xpretty <- pretty(xlim) + ypretty <- pretty(ylim) + ## Extend ranges by 4% + xrange <- c(-0.04, 0.04) * diff(xlim) + xlim + xpretty <- xpretty[xpretty >= xrange[1] & xpretty <= xrange[2]] + yrange <- c(-0.04, 0.04) * diff(ylim) + ylim + ypretty <- ypretty[ypretty >= yrange[1] & ypretty <= yrange[2]] + ## Canvas like they were in the default devices when I last checked + if (missing(width)) + width <- p$din[1] + width <- width * PPI * p2p + ## Margin row width also varies with platform and devices + ## rpix <- (p$mai/p$mar * PPI * p2p)[1] + rpix <- p$cra[2] + mar <- round(p$mar * rpix) + xusr <- width - mar[2] - mar[4] + xincr <- xusr/diff(xrange) + yincr <- xincr + xy0 <- c(xrange[1], yrange[2]) # upper left corner + ## Functions to translate scores to canvas coordinates and back + usr2xy <- function(row) { + x <- (row[1] - xy0[1]) * xincr + mar[2] + y <- (xy0[2] - row[2]) * yincr + mar[3] + c(x,y) + } + ## User coordinates of an item + xy2usr <- function(item) { + xy <- as.numeric(tcltk::tkcoords(can, item)) + x <- xy[1] + y <- xy[2] + x <- xrange[1] + (x - mar[2])/xincr + y <- yrange[2] - (y - mar[3])/yincr + c(x,y) + } + ## Canvas x or y to user coordinates + x2usr <- function(xcan) { + xrange[1] + (xcan - mar[2])/xincr + } + y2usr <- function(ycan) { + yrange[2] - (ycan - mar[3])/yincr + } + ## Equal aspect ratio + height <- round((diff(yrange)/diff(xrange)) * xusr) + height <- height + mar[1] + mar[3] + ## Canvas, finally + can <- tcltk::tkcanvas(w, relief="sunken", width=width, height=min(height,YSCR), + scrollregion=c(0,0,width,height)) + if (p$bg != "") + tcltk::tkconfigure(can, bg=p$bg) + yscr <- tcltk::tkscrollbar(w, command = + function(...) tcltk::tkyview(can, ...)) + tcltk::tkconfigure(can, yscrollcommand = + function(...) tcltk::tkset(yscr, ...)) + ## Pack it up + tcltk::tkpack(buts, side="bottom", fill="x", pady="2m") + tcltk::tkpack(can, side="left", fill="x") + tcltk::tkpack(yscr, side="right", fill="y") + tcltk::tkgrid(cp2eps, export, dump, dismiss, sticky="s") + ## Box + x0 <- usr2xy(c(xrange[1], yrange[1])) + x1 <- usr2xy(c(xrange[2], yrange[2])) + tcltk::tkcreate(can, "rectangle", x0[1], x0[2], x1[1], x1[2], outline = p$fg, + width = p$lwd) + ## Axes and ticks + tl <- -p$tcl * rpix # -p$tcl * p$ps * p2p + axoff <- p$mgp[3] * rpix + tmp <- xpretty + for (i in seq_along(tmp)) { + x0 <- usr2xy(c(xpretty[1], yrange[1])) + x1 <- usr2xy(c(xpretty[length(xpretty)], yrange[1])) + tcltk::tkcreate(can, "line", x0[1], x0[2]+axoff, x1[1], x1[2]+axoff, + fill=p$fg) + xx <- usr2xy(c(tmp[i], yrange[1])) + tcltk::tkcreate(can, "line", xx[1], xx[2] + axoff, xx[1], + xx[2]+tl+axoff, fill=p$fg) + tcltk::tkcreate(can, "text", xx[1], xx[2] + rpix * p$mgp[2], anchor="n", + text=as.character(tmp[i]), fill=p$col.axis, font=fnt.axis) + } + xx <- usr2xy(c(mean(xrange), yrange[1])) + tcltk::tkcreate(can, "text", xx[1], xx[2] + rpix * p$mgp[1], + text=colnames(sco)[1], fill=p$col.lab, anchor="n", font=fnt.lab) + tmp <- ypretty + for (i in seq_along(tmp)) { + x0 <- usr2xy(c(xrange[1], tmp[1])) + x1 <- usr2xy(c(xrange[1], tmp[length(tmp)])) + tcltk::tkcreate(can, "line", x0[1]-axoff, x0[2], x1[1]-axoff, x1[2]) + yy <- usr2xy(c(xrange[1], tmp[i])) + tcltk::tkcreate(can, "line", yy[1]-axoff, yy[2], yy[1]-tl-axoff, yy[2], + fill=p$fg ) + tcltk::tkcreate(can, "text", yy[1] - rpix * p$mgp[2] , yy[2], anchor="e", + text=as.character(tmp[i]), fill = p$col.axis, font=fnt.axis) + } + ## Points and labels + + ## The following 'inherits' works with ordipointlabel, but not + ## with zooming + if (inherits(x, "orditkplot")) { + lsco <- scores(x, "labels") + laboff <- rep(0, nrow(lsco)) + lsco <- lsco[rownames(sco),] + } else { + lsco <- sco + laboff <- round(p2p * p$ps/2 + diam + 1) + } + pola <- tcltk::tclArray() # points + labtext <- tcltk::tclArray() # text + id <- tcltk::tclArray() # index + for (i in 1:nrow(sco)) { + xy <- usr2xy(sco[i,]) + item <- Point(xy[1], xy[2], pch = pch[i], col = pcol[i], + fill = pbg[i], diam = diam[i]) + xy <- usr2xy(lsco[i,]) + fnt <- c(labfam[i], labsize[i], saneslant(labfnt[i])) + lab <- tcltk::tkcreate(can, "text", xy[1], xy[2]-laboff[i], text=labs[i], + fill = tcol[i], font=fnt) + tcltk::tkaddtag(can, "point", "withtag", item) + tcltk::tkaddtag(can, "label", "withtag", lab) + pola[[lab]] <- item + labtext[[lab]] <- labs[i] + id[[lab]] <- i + } + +############################## +### Mouse operations on canvas +############################## + + ## Plotting and Moving + ## Mouse enters a label + pEnter <- function() { + tcltk::tkdelete(can, "box") + hbox <- tcltk::tkcreate(can, "rectangle", + tcltk::tkbbox(can, "current"), + outline = "red", fill = "yellow") + tcltk::tkaddtag(can, "box", "withtag", hbox) + tcltk::tkitemraise(can, "current") + } + ## Mouse leaves a label + pLeave <- function() { + tcltk::tkdelete(can, "box") + } + ## Select label + pDown <- function(x, y) { + x <- as.numeric(x) + y <- as.numeric(y) + tcltk::tkdtag(can, "selected") + tcltk::tkaddtag(can, "selected", "withtag", "current") + tcltk::tkitemraise(can, "current") + p <- as.numeric(tcltk::tkcoords(can, + pola[[tcltk::tkfind(can, "withtag", "current")]])) + .pX <<- (p[1]+p[3])/2 + .pY <<- (p[2]+p[4])/2 + .lastX <<- x + .lastY <<- y + } + ## Move label + pMove <- function(x, y) { + x <- as.numeric(x) + y <- as.numeric(y) + tcltk::tkmove(can, "selected", x - .lastX, y - .lastY) + tcltk::tkdelete(can, "ptr") + tcltk::tkdelete(can, "box") + .lastX <<- x + .lastY <<- y + ## xadj,yadj: adjust for canvas scrolling + xadj <- as.numeric(tcltk::tkcanvasx(can, 0)) + yadj <- as.numeric(tcltk::tkcanvasy(can, 0)) + hbox <- tcltk::tkcreate(can, "rectangle", + tcltk::tkbbox(can, "selected"), + outline = "red") + tcltk::tkaddtag(can, "box", "withtag", hbox) + conn <- tcltk::tkcreate(can, "line", .lastX + xadj, .lastY+yadj, + .pX, .pY, fill="red") + tcltk::tkaddtag(can, "ptr", "withtag", conn) + } + ## Edit label + pEdit <- function() { + tcltk::tkdtag(can, "selected") + tcltk::tkaddtag(can, "selected", "withtag", "current") + tcltk::tkitemraise(can, "current") + click <- tcltk::tkfind(can, "withtag", "current") + txt <- tcltk::tclVar(labtext[[click]]) + i <- as.numeric(id[[click]]) + tt <- tcltk::tktoplevel() + labEd <- tcltk::tkentry(tt, width=20, textvariable=txt) + tcltk::tkgrid(tcltk::tklabel(tt, text = "Edit label")) + tcltk::tkgrid(labEd, pady="5m", padx="5m") + isDone <- function() { + txt <- tcltk::tclvalue(txt) + tcltk::tkitemconfigure(can, click, text = txt) + rownames(sco)[i] <<- txt + tcltk::tkdestroy(tt) + } + tcltk::tkbind(labEd, "", isDone) + } + ## Zooming: draw rectangle and take its user coordinates + ## Rectangle: first corner + pRect0 <- function(x, y) { + x <- as.numeric(x) + y <- as.numeric(y) + ## yadj here and below adjusts for canvas scrolling + yadj <- as.numeric(tcltk::tkcanvasy(can, 0)) + .pX <<- x + .pY <<- y + yadj + } + ## Grow rectangle + pRect <- function(x, y) { + x <- as.numeric(x) + y <- as.numeric(y) + tcltk::tkdelete(can, "box") + yadj <- as.numeric(tcltk::tkcanvasy(can, 0)) + .lastX <<- x + .lastY <<- y + yadj + rect <- tcltk::tkcreate(can, "rectangle", .pX, .pY, .lastX, .lastY, + outline="blue") + tcltk::tkaddtag(can, "box", "withtag", rect) + } + ## Redraw ordiktplot with new xlim and ylim + pZoom <- function() { + nxlim <- sort(c(x2usr(.pX), x2usr(.lastX))) + nylim <- sort(c(y2usr(.pY), y2usr(.lastY))) + xy <- ordDump() + ## Move labels closer to points in zoom + ## FIXME: Doesn't do a perfect job + mul <- abs(diff(nxlim)/diff(xlim)) + xy$labels <- xy$points + (xy$labels - xy$points)*mul + xy$args$xlim <- nxlim + xy$args$ylim <- nylim + orditkplot(xy) + } + ## Dummy location of the mouse + .lastX <- 0 + .lastY <- 0 + .pX <- 0 + .pY <- 0 + ## Mouse bindings: + ## Moving a label + tcltk::tkitembind(can, "label", "", pEnter) + tcltk::tkitembind(can, "label", "", pLeave) + tcltk::tkitembind(can, "label", "<1>", pDown) + tcltk::tkitembind(can, "label", "", + function() {tcltk::tkdtag(can, "selected") + tcltk::tkdelete(can, "ptr")}) + tcltk::tkitembind(can, "label", "", pMove) + ## Edit labels + tcltk::tkitembind(can, "label", "", pEdit) + ## Zoom (with one-button mouse) + tcltk::tkbind(can, "", pRect0) + tcltk::tkbind(can, "", pRect) + tcltk::tkbind(can, "", pZoom) + ## Zoom (with right button) + tcltk::tkbind(can, "", pRect0) + tcltk::tkbind(can, "", pRect) + tcltk::tkbind(can, "", pZoom) +} diff --git a/R/plot.orditkplot.R b/R/plot.orditkplot.R new file mode 100644 index 0000000..884437a --- /dev/null +++ b/R/plot.orditkplot.R @@ -0,0 +1,14 @@ +`plot.orditkplot` <- + function(x, ...) +{ + op <- par(x$par) + on.exit(par(op)) + plot(x$points, pch = x$args$pch, cex = x$args$pcex, col = x$args$pcol, + bg = x$args$pbg, xlim = x$args$xlim, ylim = x$args$ylim, asp=1) + font <- attr(x$labels, "font") + if (is.null(font)) + font <- par("font") + text(x$labels, rownames(x$labels), cex = x$args$tcex, + col = x$args$tcol, font = font) + invisible(x) +} diff --git a/R/points.orditkplot.R b/R/points.orditkplot.R new file mode 100644 index 0000000..e2dd8e0 --- /dev/null +++ b/R/points.orditkplot.R @@ -0,0 +1,5 @@ +`points.orditkplot` <- function(x, pch = x$args$pch, cex = x$args$pcex, + col = x$args$pcol, bg = x$args$pbg, ...) { + points(x$points, pch = pch, cex = cex, col = col, bg = bg, ...) +} + diff --git a/R/scores.orditkplot.R b/R/scores.orditkplot.R new file mode 100644 index 0000000..d1e478a --- /dev/null +++ b/R/scores.orditkplot.R @@ -0,0 +1,9 @@ +`scores.orditkplot` <- + function(x, display, ...) +{ + if (!missing(display) && !is.na(pmatch(display, "labels"))) + x$labels + else + x$points +} + diff --git a/R/text.orditkplot.R b/R/text.orditkplot.R new file mode 100644 index 0000000..d021760 --- /dev/null +++ b/R/text.orditkplot.R @@ -0,0 +1,9 @@ +`text.orditkplot` <- function(x, cex = x$args$tcex, col = x$args$tcol, + font = attr(x$labels, "font"), ...) { + if (is.null(font)) { + font <- par("font") + } + text(x$labels, labels = rownames(x$labels), cex = cex, col = col, + font = font, ...) +} + diff --git a/build/partial.rdb b/build/partial.rdb index 226bedcc76a0f9f4c069a9c3026399966122ed00..805ef44332cb4cc1f55bcfc6f38fce85a96e9045 100644 GIT binary patch literal 7038 zcmV-^8-e5>iwFP!000001KnNwdep{}7rtP7z&02#feR(_-M82W*tgoh_XW;(9^hoVTBVsDjbvM`p0N{upZJxT_Ec4O zb#+zW^fIR?N{`al+pF~S0(pV{b4pQq0VkTj_nc$crwmaX-8FWIeMg_I5$!G6F%+e* zhx_<+L4WO&9ZK`OBU?J@PlN@-^4oCBBj0 zC2qd#Si0eQdA*Xi-o1PC=8pd0-s^Yw-^?$(snsm4=2o38oNq)hJI&!Z@T^q~fWzel)pZIo1`(fIrqor;#~F9!7iANKqnv6S!` zZz7cIrRDm5KPuZ6(>|3;kfU#V^W}De7?(N3M?j3D_q2B5ntiK9IIxgG#BrpB>L`}$ z=_0XA;wA7sg~(M-x7!BTf5IU?lGtIoLwC(*`oEPiEmH<4D^!e_$3a}sJ5Ff!->B%Zi zKlY0d@yS>#%NzT2EHO2e*t+_{Cq5Q`E$D15qYQ3HV;G!UO|i!q2b5TbZ(fMKgy#evU8 zIK-#hwUWb{2vLrW^leuRHKinHkUJpf3%fK#A0Si?@th)iIOr?Z-tHuD?MFP1boQa( zOBIJiwdOjzrfzuP^J>(=`84feK8{$HNVAP0-b4DHu&iO8^i8osKm1Vf{hGI! & zf0!%GQn}w4nm^~bJ9*S)X=>r)2dKsml=v8C3aqgc6dC&I#b)9A)%C)&1a0mkZXvyu zR-4u|uu3%7QKE4GXv7+yA1akN%e{GoN;pX0r05e=e8j2xNJLfkgi^;ze_&G_WK&W^ zOWo@_$F-kXbSK$n8whwY9yOngV%&2YQIlFV{EDM{D)P7;i_$)tA2&}YD(eH z2A0S09@2kYCj?sDN6h4e&a~$r$M1K}qH%@Voglv>O|(>gr?XrW{f;!Y+58SKMmE25 zkU5<8G{-f(l(GR{M7)CZ6^SilnfBXAxG+@EUpqDMhcXO$n0wAQQA~lhZyrFriu6^9 zRiin2TuM6}v@OF=k^VHZ(N3%7x~;K6NF%mdA+~NAbLwNC{Yos)QFYU+S!6%0bpu{Q z+(dd)zI9hLtM2(JWg9`c0LPFX>xgx?u^m9Xfb@mVTh0ht3*behFJ`u!1(kZ0y5)PS zX+t*U?9!Nqz{C-?7Mt2oIMIZemY3FmK-^1+n@Ecp5dZ0U;u>m+c!sW0oA=Wv>!VnM zfY~Q2h@qQ4DOssK05A0;q_a;5t(e^UTCK6T)|>`H zZ5&!I@MC53Jq=Tc4_?f4(`vy5C&~)aE19);#7$cTndOXHs{5)%N`~dJtf6G6RT>TI zs_#%5Ito?FGvQBWn8Oxu%44X&7&gf%DNV8#gs`F19s#LoIJ-++)2Vyvj!SA4Q)3NP zB|e+LYZRKEE=*6S)dSrL!!@MWvd7|{;d#&^P`j=%ON$bpO38*mCMPpERdcFUTEv@6 zD>j!lC<{n0WEMO1jL9Wr9b&d6yKrb;DZVh?*W6z)pILJC85&a1k%;a4`t^hFIF`4# zxLD9%qpNvs+PbM3-p$FWg~?mtAbrR}+kwOLIBGMF?&g#tuuCU)cpfdH(2oO|gQ9F} zV{g{>0BNsqQeP2~y3H)csiekx)hVkL!>Um)QlnjP@%Utes>&U?suCiT&Q#Shc;g@p zQCoht>40p^ZkScW2FE}wZWD+42;JJr&|wR7plOsE{b|=BoKiTkx_k?|_-~oBZTaCO zhJ7`GXa3&Vh44gu%Er!3Z8aOLj92?S(Y zxHOn{@fcP`bBI$&Pl?FOZi;5*Fw*#_2XDqFX1Hu%rnV&oyBVyR%#q=dh)*ZOyZqlZ$N0DzaD} z>;(+xC2OW_!%VQPr*%5K@ZTZ*U1s4g{oQe@RG`wnT6O9k&cmk^?X$oZ8FCYQf}@(G zUGE^wr-(O@zR_{Z25#eslSofyZl#I#UGHoOqD(YH^_{e)1j0=rt|GmfS;()s^#n+( zv|xq-;t;0kGs=q~|))@y`C9-AzoQxlXpyV$!yK^Hsz=(n6jwp&k@3$r-zkl4(4eeV`TbD2@YWbo@17Zv#UP4;lLd;pqEV;zpze!u@mPi9#L*(dgG|)KWO{8yT zZlE!UKxo&32}QPDKXujx^4vmPM0zo^T&c6Jn`pBk%E`Kh!tEw$?e`Xn062v7P$v70 zT~Ner$^ycTBVI%LnnVjun5evk1pz-p`m@e=9AKA2ypHts%$6|yX%0CkS2_f z+^Y6ma}Tdj()O3YCK)avEws!UYu$ZLay*ro63i&U$N-o_I@kG8Vg|Jbf+b}=cgqn0-r@(Mp|ge`oQSt3^b)-S!T^kd+#`eWW$J; zk(PNiK|+K)i?##!3DWY;lO)>FEZPp>6{N3Zwxjb9ArqTe&JLVgPd^z9;#@_XMtZsv zR-&6?Rsw6y7ZI-`EtFYwDNLS2O9qr1CeNX<0!|=3(Rst2Lt_P0kybMsZu*sH;C};g z66wjza-^OE$zv6Sc+7Jk^C$vf=jK4p;2a2?4;Bz`TxsrO8W%O6bY6ZQ3(ljZoKs}( z=T7V_z%HjW^PZd(Bh9gB4;;OSc}yYBAUz}9Jj5>y4V%cC-Htv#+{m=&kWNs2of&P|d2OmU?`NUNRqV!-Y^;tiy`Funo1 zGl-K&XCL4C*`$j=#ZMuAg|yHT;em!R(t0b0fQ;d@+Qe=c#~k7s(reu@j+=<%iT?pzwbqA4iuaZmn(7So9Lk-nc+8z^xi zC;vgK2b^{fM6~P74CEX}lsj(*-#CES#rHOR6Er15dGBoy3Y9>FYlte+Y6oIy(J%?*x{J7kw9sl( z7j1PGaRKQCX}05m&F8-yi zm;1;%MB$t~mg`{AGqi+jyRIU)2U$61s{ml%!y!K17Gn`>AVl%nI4F4iyyZTwmMiCl zZ{~ty(mBLgq=mM^F^O+wtw<1KoB<%}cO|&E135`U;N7 z6;x?k5kwwATtix{75PuEH!i~ZIXsu8(V-tU0SdfH;~`cl;B}<0XR01(OBq1MMLHhvYw#jF-=L>4fl`qf*(;6`d z^cTb>rLjLXqhOzeceg;)%?@g@+5FV$;wn}ZpzzB)vWK;6$U4Mh-lDXQA^;8{JtW=n zIl3G6aSw3=X`yAz^!BlUDDUt>Y99vdw>ZQnqZqyEmuI;fGT^;QjP8|g znxcmYL8{A$*O3+q>e5F{LNn(ZSPt+a(if#fO7M+2#0jKjdhvwr0_^$_RixF-b~+W@ zN*QeWa~rz(9nF%X$PCBq;2jYc5w9yJ|Ck-fIgBWGyAXWi0OEwwwPSYQp;Z8?NUND` z`*U^Av@CYY80~@@wA~usq_t&`@CG6mRc4fQFbJ|z&$&Iux&jEDobh{rtV z_5?)$?C_jh@Xk;H`Nk0^l&;OWJ;8!cl&;RX0lOTcyg9d#pl?H#C~z_mWSKnA0YgT^yty&_Up{vc;vZvJHnGy`sfcKETC!zzBeKc#8f*6Y&;?wPxeU7aeq8vM4 zZ$!Dlj5oI}$I~2_y}pi)8@90*HtwEj>&{-#-ZXVjpTqo!!UJ;a(-{@n2yz%UPfSxR z(^ZYoMlDh@EPSP1K!-=kt8`e@Va>E;zy_4GniNoaKyIxnqb6H5$20NzFg7z@F{~PP zFwJ%LbeI)qdn90*AMPNsJV&K}1hf3`l0g;T6q#0+7brglh%DD#cG*Rh*k-M6;mhS*)iq}67ZSE^2YB97MbCJ<^94q~#(!Zm0fS)7%dH0+DC9)1t&TzZ24euOb zZy$C_yUcOyk$n%Gpjl;`WwDXN3Gq2~-LZYwEYpA#MWaQ;6r07FyKE)+)e$j6-}RwaVEl4Pi_OS%{yuXV1JoId?YnZe?=fuevRz_ID+&@SK8z?wgccO(xcsPlh;@-M0{j9 zF}!0YrBJ_NOZ=vE+ll>#Edh9pP7K(OaVYG>VoUWD;#3cR2&%0p0>c@U7={wz8K~32 z|20cj2~EL0&>eY1@t;a_>WMVJwHY@ReZ%u10dBH6H5gMc+@jMcbSYAR^TTJh6Y!U-U?|#uYvrQ)r;*{aANkjA;}*6DcxS)ErwgYCPY* zL;<~uv)3wM9&1w3X>Cn&m@v^!9D1=9xUd)3N-FcYLj0Y&GlX6RDeBV%2%2M-Tan-lE1= zWqXHo>b$MTbsNZD44BSqH@U?&3pI>eh#L}IXE;kaZR^8Iqu36$$KOe*KEEcT!t!5K#y#AtQ9_W1fneXQcj3xFIvus!% z|6SupXb)~mq49SEiEZcAOYOzuyjYG_WW8#*#E%SGF(YoU=G-VW9IKq?)LkvX;37?^ zmwD-uOr0uTGc=R%_R~J_LO^8iSKGg@ZM2V?R$RFuFfT_p?HwiAB&e=FWf~bu+RSvf z-R`57#TL~M3B%%hSxiBiEAZbI^?zL8erOZrip1Sv$8~wuqjBv%WtMHdB~YA{IDsWx{4o#e$`%_5%H z&OF*wt?^96HAh&R<+l2bd|lbJj3X%APsia} zr&j;>{eS=8O8Ebc^e{Z_Gw}S`i^nfDKQspRtKY2op(um({L|pwtNAUL`UBeE-+KAN zTsizDUoZkk?d81+agBUI&j(3m-rM)+KsFbqx4Gz7zslEKbC-@6c^azZ%e0fxm@BVW z^47a|Z{FO|AKZKW?*5zkg*UaDrPbVuHcx+c?EH4V;8$xeOFzDO`ZQl)tz*oW^t<;B zQYLrq=NlK59GG?w&_o&SJgG?g28{L?`FTOe9!t?8({0w*VsY@<>*s}=Qwy;+#!Vyg zH&KN)rX6{PA|Xb6O16!coT8tIEBXaSEgvk}^6x)>fHdO6hk(P!j~_n-M2wENQ7=I5 z_B2U44$<)3*|7+W!ZO-3R?Q+MeXq<8(0zn|W7Om?=vzX1NmR|qfZaG3CqqNggM;lV z<6I@f?~(pqipn&y@~9Ms9MioT*QWnTTT+eF>I!NCIFIyv7JH3LDT5l`4iZKgt-73k z6lCdY^7wZRbqC}YOS9F(kuuNGuznuXV2fqxGHPfgeGQob|KvL2-wgN)=~vQxTQiE< ze6e15{CxZIvmfNtg+R>2$&g$h{M*4}Vy2_lM@v17g!QnBak`8uc$mHlf;1sn`$^Oo zkXzQ4;16l4?3i-&o;^aqLYXCNnMch4SCC%G+{R;J8-Gtsb^zay)XwYa+qv2hA-NW~ zGY5)}v@YE{MslofKdsSZLC3h8*QeguWPs)*c1X`+`!q6>W`tC8jT%j2pdnZ`_3$4` c_|ulx!t{t2(PAu)h4Qce2Qzx#YaQ4C0E~p}JOBUy literal 6323 zcmb7|28pr8>Er$?(S}+OJD#QK$<~X96*F229OR31%`I$`f-2P zdj5dtyxIHJS^KPOf3CC7p-aU?`rkrbw}2b30@{p&UcGIOV`jD!kdGcu#akj2z&gr0 zoAUabZJxL+*bBG#!ae>enOi(ZL&3-AxjOV@usss;=rtYjbu+-Dz@Tk4guG!vVA3n& zf@}Mo;ev$)h|?b&IfWH7!-TjrCkzRR?o)XBN{`te1uh=EHuq`OCTA3jXrxsewY48$ z9rvtJG^CHz4i9VnOf3dusN9!5yr0wZ7F>dL*{L@X22`JwjH!{!^(7!Whph0j20>0e z*rKF;6_M!0h!b+3sK{sS``&-kD97lAiXx;?Ol+=KD|q6jhMhF^rcBqgu>>Md=aJe2 z52w#xDV&!0;5qI)>mgy$R)Zn!*X>6)roDp_ad*Z#)H)McAQ!pPoiHdYgGB{Or*1T0 zbC}|?e0#C_@C`OLELn3l0kiFG@wxfZxR0Suy0hMnaw{%$aerH--^3$*`}z3I#fXo^ zT;7O%aIkZ5uxf;t@Bn zsrK|^SON|1`b&f@{c|0nespb1p7~PH0l)9m@8bFQSAq9k#=v7)#kDP@TZ_RG*Tzq# z?EA1Vn^&rrHDhd2E}0T5#C7sHRT z1!Vev&SUW^sHbq8R?JuRy{F4~ zwPg?F3yd^~dVCch#Gj$2ZR&mJZF!Sq{L|88Rfb{uwI&&hBGIN;j^dB8)os^xKkC}?DSiIzuuC2<$YDmV zuZL%p{wgZ-sQ)*{dOak1dXyc~u-c#Vz5FaYGaYeES8t=Bnvg9?zlYt6i1T1Fz(3C! zx_6#22K7s){a(ooqBuZk$AmJ<5RDYu)4Ha(#7;EK@@m8U^FNfxg{2_$9ZVk0kKiz( z+q1dso%y4Mu!x54^Bo26@*j_>oRT=T{)H+QzZ~AkM#gwNC?!otRBho0q%kVW_Ahfh zwX_ET$j0G7bBKsfp}|jB+9R`+Oiz+>=WTL@@yS*qP#b+NUiih19rL# z{bBXhKu<}MW4Dx4r({Qq0P}l`)Ttcz9t>oj(TP8KdTDhIf=M9IRCfIm;|;}*l294b z!fVBf)T!*M4bMEPpI>2*48KKiTE`J^|C4L>9<7wc#neMRTsqD?)tfq{Exjc*S z2fwGgOAIQeW>1}V2qva>xtW5>bVP<4lJo)E-qaKpf*a_=@s(9R*1v}6F5d3z9`>v$ ziJ&P2(#rKEBQ!HCm`c4ii~l2z7s^4hMx!Jo0O=eXX50oY2@~1QN%3HEfKoTA#h#gD=^iWZ}n;A~%p$>A0x&jt;(utfV zPR7SMYy5g53a)?*zm2MSyeN+bI=pq_FghLavK_UlB{yZ&oTl z;UAn%1;u2pwC#$4&?H8UE>^Vsn=2D1`Iz*zFBLHE0;^osfQcfa>^z<=PQi!3QzxPA z$<&gh35iyaS5l zb<9x95R-m<?kfU-;3KQdK?thq5pASpIa|+(k2H0iXeoh1OX3)XZc-=-I~kG z+-3|FX#x$?5}~yX<%<0CzI8Se(=y)NhYwvwhIl2+^*LIDB@xc5olLO0zlw<#GtqIe zHfL;&u@#hMW)^GPor)0rj4=_criV+UZ5ijSzv0ac2a@j@#dS+rx~dcOUla)v{nadje-#Vvz1KH>$CNk5r|(Lbg0kP$8pfZQ9!T5| zoL+AnjjdJIeO5yFfB?3jV1G%Zk;dBSNn|JH#q6A_mA0A>{IZa6OmR!i?=+@DG89IA z6g>^S6L*iMx5~8PXnI#VNygyBBg(^F+a6_eX$8NS2x8i^t+};BEG5C-n+W;?Dxm5& zGr?D4sR-`WzAvSlHODf9JGAjZ{-GoX$`_8k`)NO?;`~ylc(EKU#?Wc*h>DEUYj{2E z^~cc5SlQQE-}_BeWk5Asl;RuRzK)W$b+@`}wnG#(?)!TDx6+Hi^q7{Ae8br<&Iy&A zgo7;p5*=rojF0XvznjB_pqxaX!x)XAJx#nxxRy>o+m+wcvr+Hpr_aHR3IE_gBmshk zSi~kGUL{JU@*%93?3#%M11{*vk6by8DH%ocALY7DAb3DgJ)B#J+qxIM=mqgCcPv4t z^v=a1=MrNp7+4!X48=Laf@w!o6G+Ycc7Qs-2dd#W;+n>J|emHIAO+aBfp z(9URA&0?aGnZGNm>LWhSR3M;z@Z+WIx>s4cGj&74U!$$S5fZ#ysenx8*dWdK3<{;` zdpKHBFK0_m1XY^mlpEl={LY8V@L@`=IhKFcnZ<|a|CNWPaCK5CNcqHrmG6Hv!j%@8 z3?sN$N$$w7u?tlsDh?^2&I&PdkxJ%@#hWK>OZMhNCs^CQzzW9`j3_hYb2J#AUWwNB zE3&0#{Ul>G{s2<_FUI5C2$!=Hk~!SfY+RG@U2PFvQ7HI?r0FvV-{FJ@F+<(yqF7jJ zP{21^h#Z)`q1iM+`nvI+I45q*gMp>e8mvn$2QnB79^C`Ier1wVE+&Wm^@Nd^zCUXm zLUk+LUxLJ;450uPp}>DgZYoVOL3b%^?-(59*;;y2-plo5t$2jKZmvaoN=;G+@cD1D zXzt*ipC7rnF#2FTG%e1{B}PCt%{1}+ia+_4SkLmLlEju+Co81B^hYiE+EN$d&Zl}y zH&1H~P%f2OW2-t>)AnW9#((M1Y>oxPQYZ(hsPfZ0^?_KwyPAX579K*&$Pkmn<^+dc zQ-J?i<8Xr`<5M!bc!p9;u)X|RLlT>VMHn9izM}Ns3`a1p2UCC9Mxek)M~5uQEzkA9 z82rbiLD5a|*sBwGfJYdc=(pFmQ!ka=X?eJzhK5j*{!;m3T>r~m#XvZ4P=FgcBa<~> zYs$hq7eHJBJV_u6B|gw(ZDk4^cwKE`kq-a4{j1@)472D{oOF~}8p7*J{-LohDs`Uq zVtI$dNgzwyPX}SO4iNz`3F%b+Mk>^!Ov zG7)Bxsg6#^aTgB$YTCRa#1Lq#KanQ}zr%L_r6Oapm^HY@T>rSCOoWt}MXP2%n9WDx zoz55Qm74_48W@?4vBk~{Y-QLg07Mo&LXZQ*D@_=FVo62#Zi{k9PS-=bBMnXt_y*`$uBzw7h7lH(LxIo3^5Q=N`nW4ZthU znm0R+|3hh63p^fh%;o*U07VoF!+P!~Z-O{QSfYZ$koXh*c<<{VsPnX05*_?|)-qT6 zuBy6c_O-SthZxX+z=EyN2kb{Rp##F0A*Q71Y=;p0b&)%Ygh~T{i-u*@Y1#y42ah|*#IO@dZ?$YY9o!b(kgPPLI`IkjYR^ci2(Duln`7*k)Is$HCZeXVNPaL z<>Y3BqF|v6w2UcVeH)C=Ly_fKD3v&hEtZb(yGoFJ$=DfrYDLy|J}iI~brlV8vU(u4_@Xea5nn5&Y6a&MXcU1YZWX6pE;jxv3@)|!j9v`6Te zrR50}7hOSBnYN*APa=UXOD$>Hp#~cfRxm+HJ~4yS#*+B5B4%kO3RTQiLi+DdaF#q@ z++B^|k`q+<{!b-~;p2DYGo@~6l`y_<9NjAnv}(60S$ zb>LjZ_C1WWEN*kJN3m=j{?uF%zTj@?oIWjY-wcrxYEbKhOoP!3tfLzQlJS@`8^d@1 zg-r<0&Bk4j=%C9T-b75%axY5B#>fxAlNez(SC+U-7Vr9E{oa&&4tczH`gNIrMmr6T z0PhdaoVO=k$B#BBOeOID3Sq~HO`Axf0tg1L?vA!bbtfYn0@HSox5;2;>(|yp5hV(J zdMW3G*RbTAlh0&Q%^6Gqp2NfpmEEc33ts`GSmYzp@NHQq{=^&H14q@)XtKX;Hw30l zIx9^rP6e9h6(vry=C&!%%RcEmPrkM#Q*$#mjY51I%cT0|ZOlQP0z(`O6LV{~^H8}d zU8Mnk!R{R-n>PfWRu>5{<%mSEV7warFpm=jT)WO56ImqUq5oRSk)0Wf3(3BCF^FL8m9|&IAI(th)lk>r!cwy zQJSmbL&LocqV{!LWcCTo$@lHSN4k4a{u$i?UNuMXmhT0mgj44 z%7X)qKCPr9?AS^DLQ#g`9ukOZaD;FypUEYF=a1+d?p@{-8-eF0A8J{STHJ?7S@7r`G-$|Iu-8wvPP& zuz()odsMN2e%MV2cSVh*ySriz3-}weL%2qA2bDvEwx>t@HP=`HS@tyER0q7T;)kZ1 z-H++R(d8LhHfyr9b-L5c_)FNJ-x)o{rY6N1P13Imu}if}3@&)4QOtoGe|$0+_1)T0 zZF^FJ%*38okN$_&MEusvJu;`T*tP6lZHSZtNUe9j=Q{7Ng`e=+cHr2|ymJl8ozIsa zmQ?U{=Yess&>&(OA;MsqBd#HNAV%+LaX@xwrlYxUwMdqoh3~%sfsgV7su1T&S7C6$ z(pk;SLNQg#1j9wc*Ysdtsy3yBvS|7VTpQX0sX&|$s}z_5;j!J(h>xEnm! zrk&@|&0FTMB; zpO)fWB;+gtu0oA5#194V~3q7|Iqrk%e5Oq&dHqJ>*ty;GYcf3XVd) z5`jnYovl>s$v-fduE;$!sP(vaf#|rbwd;dYD)I7;h`%>37q5flKmYa`*V)_&WYE!U zPL$jfqE_j2w#CB#?S!=2o1ekbuSIYjWYA!elkQ3i zT5y9jN@kP~(JU*qrlt*WL z^wX4plKhYg96R|~a!DLGBe0NY+d+lm=*U^@%?_D9jLtcJ@1UMr=uEj^*i)lI;Oyjp z=D071aXt7RMmkp+>c+jx%nYBgxKRgF5|n7|i!eA;v#1|Ck?H9wQHkC&cQ5Firx^8+kvGn)L@9KTvK_Pp3(!~(ww38ZeK2=yTxJN+%o9%T%Ke5<`PX6p(og>V&k z+WCy_B^M^%UBd?M1Z(#30+dgyuJ3@kmCt9l#JfusGQrd`kxvifOpJc!3jIj+W!0sA z)Qks3!JpL$-TskJ1B6wDF2A*Moxs+n&phLb5kzRNfaX>ZMG&U2(b~mKmcOdcdwXt! z9)RJf_-BnOh7v&K1^;@9uI*ig9rFl#Q>_m15DF|_=!!C%@&mzX=p_qn^_|qM?M#!$ zh%Az4&@8c|tz&1kG&DtVK