Last updated on 2018-02-20 13:49:58 CET.
| Flavor | Version | Tinstall | Tcheck | Ttotal | Status | Flags |
|---|---|---|---|---|---|---|
| r-devel-linux-x86_64-debian-clang | 1.1.0 | 7.07 | 406.53 | 413.60 | OK | |
| r-devel-linux-x86_64-debian-gcc | 1.1.0 | 7.20 | 293.20 | 300.40 | OK | |
| r-devel-linux-x86_64-fedora-clang | 1.1.0 | 139.86 | ERROR | |||
| r-devel-linux-x86_64-fedora-gcc | 1.1.0 | 135.70 | ERROR | |||
| r-devel-windows-ix86+x86_64 | 1.1.0 | 16.00 | 142.00 | 158.00 | OK | |
| r-patched-linux-x86_64 | 1.1.0 | 4.31 | 427.54 | 431.85 | OK | |
| r-patched-solaris-x86 | 1.1.0 | 854.30 | OK | |||
| r-release-linux-x86_64 | 1.1.0 | 4.02 | 439.55 | 443.57 | OK | |
| r-release-windows-ix86+x86_64 | 1.1.0 | 11.00 | 195.00 | 206.00 | OK | |
| r-release-osx-x86_64 | 1.1.0 | ERROR | ||||
| r-oldrel-osx-x86_64 | 1.1.0 | ERROR |
Version: 1.1.0
Check: package dependencies
Result: NOTE
Package suggested but not available for checking: ‘RDRToolbox’
Flavors: r-devel-linux-x86_64-fedora-clang, r-devel-linux-x86_64-fedora-gcc, r-release-osx-x86_64
Version: 1.1.0
Check: tests
Result: ERROR
Running ‘demos.R’ [22s/27s]
Running ‘testthat.R’
Running the tests in ‘tests/demos.R’ failed.
Complete output:
> ## as in the rgl package
>
> library(loon)
Loading required package: tcltk
>
> # options(demo.ask=FALSE)
>
> is_windows <- Sys.info()['sysname'] == "Windows"
>
> for(demo in demo(package="loon")$results[,"Item"]) {
+ if (!(demo %in% c("loon", "lsystem"))) {
+ # on windows all the image resizing seem to use up too much memory
+ # when all the demos are run sequentially
+ if (!(is_windows && grepl("^l_ng_", demo))) {
+ demo(demo, package="loon", character.only=TRUE)
+ }
+ }
+ }
demo(l_add_regressions)
---- ~~~~~~~~~~~~~~~~~
> # Define a function addRegressionLines that takes a scatterplot
> # handle as argument and creates a GUI to fit regression lines
> # of a specific order to the selected points
>
> local({
+
+ addRegressionLinesGUI <- function(p) {
+ force(p)
+ addRegressionLine <- function() {
+ sel <- p['selected']
+ if (sum(sel)==0) return()
+ xs <- p['x'][sel]; ys <- p['y'][sel]
+ fit <- lm(ys ~ poly(xs, as.numeric(tclvalue(degree))))
+ xrng <- seq(min(xs), max(xs), length.out = 20)
+ ypred <- predict(fit, newdata=data.frame(xs = xrng))
+ l_layer_line(p, x=xrng, y=ypred, color=as.character(color),
+ linewidth = 4, index=0, label=paste("degree", tclvalue(degree)))
+ l_configure(p, color=color, glyph='ocircle', which=sel)
+ }
+
+ updateColor <- function() {
+ col <- as.character(tcl('tk_chooseColor', initialcolor=color))
+ if (col!='') {
+ tkconfigure(b_col, bg=col, activebackground=col)
+ color <<- col
+ }
+ }
+
+ tt <- tktoplevel()
+ tktitle(tt) <- 'Add Regression Line'
+ degree <- tclVar('1')
+ color <- 'red'
+ s <- tkscale(tt, orient='horizontal', variable=degree,
+ from=1, to=8, resolution=1)
+ b_col <- tkbutton(tt, bg=color, activebackground=color, command=updateColor)
+ b_add <- tkbutton(tt, text='add', command=addRegressionLine)
+ tkgrid(tklabel(tt, text='degree:'), s, b_col, b_add, sticky='s', pady=5)
+ tkgrid.columnconfigure(tt, 1, weight=1)
+ tkgrid.configure(s, sticky='ew')
+ }
+
+
+ ## For example, for generated data
+ x <- runif(500)*7
+ y <- sapply(x, function(x) {
+ if (0 <= x && x < 2) {
+ 5*x + rnorm(1,0,1)
+ } else if (2 <= x && x < 5) {
+ 8.6 + 2*x-.6*x^2 + rnorm(1,0,.5)
+ } else {
+ 8.5 - log(x) + rnorm(1,0,.8)
+ }
+ })
+
+ p <- l_plot(x,y)
+ addRegressionLinesGUI(p)
+ })
<Tcl>
demo(l_glyph_sizes)
---- ~~~~~~~~~~~~~
> require(RnavGraphImageData) || stop("Neeed RnavGraphImageData package")
Loading required package: RnavGraphImageData
[1] TRUE
> if (loon:::.withTclImg) {
+ local({
+ # Plot glyphsizes for different glyphs
+ sizes <- c(0:10) # seq(15,25,by=5)
+ ns <- length(sizes)
+
+ glyphs <- c('sizes', 'circle', 'square', 'triangle', 'diamond',
+ 'text', 'image', 'stars', 'parallel', 'polygon')
+ ng <- length(glyphs)
+
+ ## ns+1 for labels
+ x <- rep(1:(ns+1), ng)
+ y <- rep(c(9, 8, 7.5, 7, 6.5, 6, 5, 3, 1,-1), each=ns+1)
+
+ p <- l_plot(x,y, showLabels=FALSE)
+
+
+ for (i in seq_along(glyphs)) {
+ assign(paste0('i_',glyphs[i]), seq((i-1)*(ns+1)+1,i*(ns+1)))
+ }
+
+
+ ## Size Labels
+ labelsize <- 6
+ psizes <- rep(c(labelsize, sizes), ng)
+
+ c_psizes <- as.character(psizes)
+ c_psizes[c_psizes=="0"] <- "<1"
+
+ g_sizes <- l_glyph_add_text(p, text = c_psizes, label="size labels")
+
+ p['glyph'] <- g_sizes
+ p['size'] <- psizes
+
+ l_configure(p, color='black', size=labelsize, which=i_sizes)
+
+ ## Primitive Glyphs
+ l_configure(p, glyph='circle', which=i_circle)
+ l_configure(p, glyph='square', which=i_square)
+ l_configure(p, glyph='triangle', which=i_triangle)
+ l_configure(p, glyph='diamond', which=i_diamond)
+
+
+ ## text glyph
+ g_text <- l_glyph_add_text(p, text = rep("aA", p['n']), label='text glyphs')
+ l_configure(p, glyph=g_text, which=i_text)
+
+
+ ## Images
+ data(faces)
+ faces.imgs <- l_image_import_array(faces, 64, 64, img_in_row = FALSE)
+ faces.imgs[1]
+ g_image <- l_glyph_add_image(p, image=rep(faces.imgs[1], p['n']), label='frey faces')
+ l_configure(p, glyph=g_image, which=i_image)
+
+
+ ## Stars
+ g_stars <- l_glyph_add_serialaxes(p, data=oliveAcids,
+ label='star glyphs', showArea=FALSE,
+ showAxes = TRUE, showEnclosing = TRUE)
+ l_configure(p, glyph=g_stars, which=i_stars)
+
+ ## Parallel
+ g_parallel <- l_glyph_add_serialaxes(p, data=oliveAcids,
+ label='parallel coords', linewidth = 3, axesLayout = 'parallel',
+ showAxes = TRUE, showEnclosing = TRUE, showArea=FALSE)
+ l_configure(p, glyph=g_parallel, which=i_parallel)
+
+
+ # Polygons
+ # hand drawn
+ airplane_coords <- c(30.8,0.5,57.4,27.1,85.6,16.5,89.9,17,78.7,30.9,183.5,27.7,
+ 223.5,6.4,234.6,7.4,222.9,22.3,240,21.8,253.8,26.1,264.5,
+ 33.5,276.2,39.4,283.1,42,286.5,50.6,282,57.5,273.5,63.9,
+ 260.2,69.7,246.9,72.4,217.1,76.1,176.6,78.8,151.6,78.8,
+ 88.8,105.9,62.7,95.8,117,70.8,87.7,70.8,73.9,68.1,56.3,
+ 63.3,44.6,53.2,20.7,61.2,11.6,57.5,34,44.2)
+ x_ap <- airplane_coords[seq(1, length(airplane_coords), by=2)]
+ y_ap <- airplane_coords[seq(2, length(airplane_coords), by=2)]
+ ## center-scale
+ d_ap <- diff(range(x_ap, y_ap))/5 # 5 is min width or height of airplane if size <= 1
+ x_aps <- (x_ap-mean(x_ap))/d_ap
+ y_aps <- (y_ap-mean(y_ap))/d_ap
+
+ g_polygon <- l_glyph_add_polygon(p, x=lapply(seq_len(p['n']), function(arg) x_aps),
+ y = lapply(seq_len(p['n']), function(arg) y_aps),
+ label='airplane')
+ l_configure(p, glyph=g_polygon, which=i_polygon)
+
+
+ ## Row Labels
+ vapply(glyphs, function(g) {
+ get(paste0('i_', g))[1]
+ }, numeric(1))## Row labeling
+
+ g_row <- l_glyph_add_text(p, text=rep(glyphs, each= ns+1), label='glyph labels')
+
+ i_rowlabels <- vapply(glyphs, function(g) {
+ get(paste0('i_', g))[1]
+ }, numeric(1))
+
+ l_configure(p, glyph=g_row, color='black', which=i_rowlabels)
+
+ })
+ } else {
+ cat("need the tkimg tcl extension installed to run this demo.\n")
+ }
need the tkimg tcl extension installed to run this demo.
demo(l_glyphs)
---- ~~~~~~~~
> require(PairViz) || stop("Package PairViz is required.")
Loading required package: PairViz
Loading required package: TSP
Loading required package: gtools
Loading required package: graph
Loading required package: BiocGenerics
Loading required package: parallel
Attaching package: 'BiocGenerics'
The following objects are masked from 'package:parallel':
clusterApply, clusterApplyLB, clusterCall, clusterEvalQ,
clusterExport, clusterMap, parApply, parCapply, parLapply,
parLapplyLB, parRapply, parSapply, parSapplyLB
The following objects are masked from 'package:stats':
IQR, mad, sd, var, xtabs
The following objects are masked from 'package:base':
Filter, Find, Map, Position, Reduce, anyDuplicated, append,
as.data.frame, basename, cbind, colMeans, colSums, colnames,
dirname, do.call, duplicated, eval, evalq, get, grep, grepl,
intersect, is.unsorted, lapply, lengths, mapply, match, mget,
order, paste, pmax, pmax.int, pmin, pmin.int, rank, rbind,
rowMeans, rowSums, rownames, sapply, setdiff, sort, table, tapply,
union, unique, unsplit, which, which.max, which.min
Attaching package: 'graph'
The following object is masked from 'package:loon':
complement
[1] TRUE
> local({
+ p <- with(olive, l_plot(oleic~arachidic, color=Area))
+
+ ## Text
+ readline("press the return key to continue: next are text glyphs")
+
+ gt <- l_glyph_add_text(p, text=as.character(olive$Area))
+ p['glyph'] <- gt
+
+ ## Images
+
+ if (loon:::.withTclImg) {
+
+ readline("press the return key to continue: next are image glyphs")
+
+ path <- file.path(find.package(package = "loon"), "images")
+ files <- list.files(path, full.names=TRUE)
+ imgs <- l_image_import_files(files)
+ names(imgs) <- gsub("\\.png$", "", basename(names(imgs)))
+ area <- gsub("^.*-", "", as.character(olive$Area))
+ areaimages <- imgs[match(area, names(imgs))]
+ gi <- l_glyph_add_image(p, images=areaimages)
+ p['glyph'] <- gi
+
+
+ readline("press the return key to continue: next reuse single image")
+
+ l_configure(c(p,gi), images=areaimages[1])
+ ## or also just
+ ## l_configure(gi, images=areaimages[1])
+ }
+
+
+ ## Serialaxes
+ readline("press the return key to continue: next star glyphs")
+
+ sa <- l_glyph_add_serialaxes(p, data=oliveAcids)
+ l_configure(p, glyph=sa)
+
+ readline("press the return key to continue: next configure stars")
+
+ l_configure(sa, showEnclosing=FALSE, linewidth=2)
+ l_configure(sa, showArea=FALSE)
+
+ readline("press the return key to continue: next stack all Umbria glyphs")
+
+ p['selected'] <- olive$Area == "Umbria"
+ l_move_valign(p,'selected')
+ l_move_halign(p,'selected')
+ l_configure(p, size=40, which='selected')
+ l_scaleto_selected(p)
+ l_configure(sa, showEnclosing=TRUE, bboxColor="steelblue", showArea=FALSE)
+ p['selected'] <- FALSE
+
+ readline("press the return key to continue: next parallel coordinates")
+
+ l_move_reset(p)
+ p['size'] <- 4
+ l_scaleto_world(p)
+ l_configure(sa, axesLayout="parallel")
+
+ readline("press the return key to continue: next change the sequence")
+
+ l_configure(sa, sequence=as.vector(t(hpaths(names(olive)[-c(1,2)]))))
+
+ readline("press the return key to continue: next show axes")
+
+ l_configure(sa, showAxes=TRUE)
+
+ readline("press the return key to continue: switch back to star glyphs")
+
+ l_configure(sa, axesLayout="radial", showAxes=FALSE, showEnclosing=FALSE)
+
+
+ ## Polygon Glyphs
+ readline("press the return key to continue: add polygon glyphs")
+
+ x_star <-
+ c(-0.000864304235090734, 0.292999135695765, 0.949870354364736,
+ 0.474503025064823, 0.586862575626621, -0.000864304235090734,
+ -0.586430423509075, -0.474070872947277, -0.949438202247191, -0.29256698357822)
+ y_star <-
+ c(-1, -0.403630077787381, -0.308556611927398, 0.153846153846154,
+ 0.808556611927398, 0.499567847882455, 0.808556611927398, 0.153846153846154,
+ -0.308556611927398, -0.403630077787381)
+ x_cross <-
+ c(-0.258931143762604, -0.258931143762604, -0.950374531835206,
+ -0.950374531835206, -0.258931143762604, -0.258931143762604, 0.259651397291847,
+ 0.259651397291847, 0.948934024776722, 0.948934024776722, 0.259651397291847,
+ 0.259651397291847)
+ y_cross <-
+ c(-0.950374531835206, -0.258931143762604, -0.258931143762604,
+ 0.259651397291847, 0.259651397291847, 0.948934024776722, 0.948934024776722,
+ 0.259651397291847, 0.259651397291847, -0.258931143762604, -0.258931143762604,
+ -0.950374531835206)
+ x_hexagon <-
+ c(0.773552290406223, 0, -0.773552290406223, -0.773552290406223,
+ 0, 0.773552290406223)
+ y_hexagon <-
+ c(0.446917314894843, 0.894194756554307, 0.446917314894843, -0.447637568424085,
+ -0.892754249495822, -0.447637568424085)
+
+
+ x_polygon_glyph <- lapply(as.character(olive$Region), function(region) {
+ if (region == "North")
+ x_cross
+ else if (region == "South")
+ x_star
+ else
+ x_hexagon
+ })
+
+ y_polygon_glyph <- lapply(as.character(olive$Region), function(region) {
+ if (region == "North")
+ y_cross
+ else if (region == "South")
+ y_star
+ else
+ y_hexagon
+ })
+
+ gl_pol <- l_glyph_add_polygon(p, x=x_polygon_glyph, y=y_polygon_glyph, label="polygon")
+
+ p['glyph'] <- gl_pol
+
+ readline("press the return key to continue: don't fill polygon glyph area")
+
+ gl_pol['showArea'] <- FALSE
+
+ ## Mix glyphs
+ readline("press the return key to continue: mix between different glyphs")
+
+ g <- sample(
+ c(
+ 'circle', 'square', 'triangle', 'diamond',
+ 'ocircle', 'osquare', 'otriangle', 'odiamond',
+ gt,
+ if (loon:::.withTclImg) gi else NULL,
+ sa, gl_pol
+ ),
+ dim(olive)[1], replace=TRUE
+ )
+ p['glyph'] <- g
+
+ ## Pointrange Glyphs
+ readline("press the return key to continue: next pointrange glyphs")
+
+ avg <- with(chickwts, tapply(weight, feed, mean))
+ sd <- with(chickwts, tapply(weight, feed, sd))
+
+ min <- with(chickwts, tapply(weight, feed, min))
+ max <- with(chickwts, tapply(weight, feed, max))
+
+ p1 <- l_plot(avg~sd)
+ g.p <- l_glyph_add_pointrange(p1, ymin=min, ymax=max)
+
+ p1['glyph'] <- g.p
+
+ })
press the return key to continue: next are text glyphs
press the return key to continue: next star glyphs
press the return key to continue: next configure stars
press the return key to continue: next stack all Umbria glyphs
press the return key to continue: next parallel coordinates
press the return key to continue: next change the sequence
press the return key to continue: next show axes
press the return key to continue: switch back to star glyphs
press the return key to continue: add polygon glyphs
press the return key to continue: don't fill polygon glyph area
press the return key to continue: mix between different glyphs
press the return key to continue: next pointrange glyphs
demo(l_knn)
---- ~~~~~
> local({
+
+ highlight_knn <- function(p, data, k=5, method='euclidean') {
+
+ if(!is(data, 'data.frame'))
+ data <- as.data.frame(data)
+
+ ## Create Custom Control Panel
+ tt <- tktoplevel()
+
+ onOff <- tclVar('1')
+ tkgrid(tkcheckbutton(tt, text='on/off', variable=onOff), sticky='w')
+
+ k <- tclVar(k)
+ f1 <- tkframe(tt)
+
+ e <- tkentry(f1, width=3, textvariable=k)
+ tkbind(e, '<Return>', function()hNN())
+ tkgrid(f1, sticky='w')
+ tkpack(tklabel(f1, text='k='), e, side='left')
+
+ tkgrid(tklabel(tt, text='Nearest to:'), sticky='w')
+ distFrom <- tclVar('points')
+ f2 <- tkframe(tt)
+ tkgrid(f2, sticky='w')
+ tkpack(tkradiobutton(f2, text='points', variable=distFrom,
+ value='points', command=function()hNN()),
+ tkradiobutton(f2, text='mean', variable=distFrom,
+ value='mean', command=function()hNN()),
+ side='left')
+
+ tkgrid(tklabel(tt, text='Space:'), sticky='w')
+ chbtns <- lapply(names(data), function(name) {
+ bvar <- tclVar('1')
+ b <- tkcheckbutton(tt, text=name, variable=bvar,
+ command=function()hNN())
+ tkgrid(b, sticky='w', padx=2)
+ return(bvar)
+ })
+
+
+ ## Create Nearest neighbour highlighting Functionality
+
+ if(!is(p, 'loon'))
+ class(p) <- "loon"
+
+ n <- nrow(data)
+ ## Which variables are used for D
+ cachedSpaceSelection <- rep(TRUE, ncol(data))
+ D <- as.matrix(dist(data, method = method))
+ I <- matrix(rep(1:n, n), ncol=n, byrow=TRUE)
+
+ inds <- 1:n # used for subsetting
+
+ ## Cache point gyph attributes that are used for highlighting
+ glyphCache <- character(0)
+ whichCache <- integer(0)
+ sizeCache <- integer(0)
+
+ ## Function that highlights nearest neighbours
+ hNN <- function() {
+
+ ## reset cached point glyphs attributes
+ if (length(whichCache) > 0) {
+ l_configure(p, glyph=glyphCache, size=sizeCache, which=whichCache)
+ whichCache <<- integer(0)
+ }
+
+ if (tclvalue(onOff) == '0') return()
+
+ isel <- which(p['selected'])
+ if (length(isel) == 0 || length(isel) == n) return()
+
+ spaceSelection <- vapply(chbtns,
+ function(b)as.logical(as.numeric(tclvalue(b))),
+ logical(1))
+
+ if(tclvalue(distFrom)=='points') {
+ if(!identical(cachedSpaceSelection, spaceSelection)) {
+ D <<- as.matrix(dist(data[, spaceSelection]))
+ cachedSpaceSelection <<- spaceSelection
+ }
+ chng_which <- unique(c(I[isel, -isel])[order(c(D[isel, -isel]))])
+ } else {
+ p_mean <- apply(data[isel, spaceSelection], 2, mean)
+ d <- apply(data[-isel, spaceSelection], 1,
+ function(row) dist(rbind(row, p_mean)))
+
+ chng_which <- (inds[-isel])[order(d)]
+ }
+
+ kval <- tclvalue(k)
+ if (grepl('[[:digit:]]+', kval)) {
+ kval <- as.numeric(kval)
+ } else {
+ kval <- 5
+ }
+
+ ksel <- min(length(chng_which),kval)
+
+ whichCache <<- chng_which[1:ksel]
+ glyphCache <<- p['glyph'][whichCache]
+ sizeCache <<- p['size'][whichCache]
+ l_configure(p, glyph='csquare', size=seq(25, 8, length.out = ksel), which=whichCache)
+ }
+
+ l_bind_state(p, 'selected', hNN)
+ }
+
+ ## For example,
+ sOiveAcids <- data.frame(scale(oliveAcids))
+ p <- with(sOiveAcids, l_plot(oleic~stearic, color=olive$Area))
+ highlight_knn(p, data=sOiveAcids, k=5)
+
+ l_aspect(p) <- 1
+
+ readline("press the return key to continue: next in a navigation graph setting")
+
+ nav <- l_navgraph(oliveAcids, color=olive$Area)
+ highlight_knn(nav$plot, sOiveAcids)
+ l_aspect(nav$plot) <- 1
+
+
+ })
press the return key to continue: next in a navigation graph setting
demo(l_layers)
---- ~~~~~~~~
> local({
+ p <- with(olive,
+ l_plot(x=linoleic, y=oleic,
+ color=Region, title="Olive Data"))
+
+
+ ## Layer a Group
+ l.g <- l_layer_group(p, label="Drawings", parent="root", index="end")
+
+
+ ## Layer Points
+ readline("press the return key to continue: next add points layer")
+
+ l.pts <- l_layer_points(p,
+ x=c(200, 450, 1800),
+ y=c(6000, 8000, 7000),
+ color=c("green", "orange", "lightblue"),
+ parent=l.g)
+
+ l_scaleto_layer(p, l.pts)
+
+ readline("press the return key to continue: next scale to world")
+
+ l_scaleto_world(p)
+
+
+ readline("press the return key to continue: next configure size and color")
+
+ l_configure(l.pts, color="thistle", size=30)
+
+ readline("press the return key to continue: next re-initialize points")
+
+ l_configure(l.pts,
+ x=seq(from=200,to=1600, length.out=20),
+ y=seq(from=6000,to=8000, length.out=20),
+ color="steelblue", size=20:39)
+
+
+ readline("press the return key to continue: next re-label and move layer")
+
+ l_layer_relabel(p, l.pts, "Different Sizes")
+ l_layer_move(p, l.pts, parent="root")
+
+
+ ## Polygon
+
+ readline("press the return key to continue: next layer a polygon")
+
+ i <- with(olive, chull(linoleic, oleic))
+
+ x.hull <- olive$linoleic[i]
+ y.hull <- olive$oleic[i]
+
+ l_layer_polygon(p, x.hull, y.hull, color="thistle",
+ linecolor="black", linewidth=4, parent=l.g)
+
+
+ ## Rectangle
+
+ readline("press the return key to continue: next layer a rectangle")
+
+ l_layer_rectangle(p, x=c(1100, 1300), y=c(7600, 8300), linewidth=2)
+
+ ## Oval
+ readline("press the return key to continue: next layer an oval")
+
+ l_layer_oval(p, x=c(1500, 1750), y=c(7900, 8100),
+ color="", linecolor="orange", linewidth=4)
+
+ ## Line
+ readline("press the return key to continue: next layer a (regression) line and polygon")
+
+ x <- with(olive, linoleic[Region=="North"])
+ y <- with(olive, oleic[Region=="North"])
+
+ fit <- lm(y~x)
+ ##summary(fit)
+
+ xr <- seq(from=min(x), to=max(x), length.out=20)
+ yp <- predict(fit, data.frame(x=xr), interval="prediction")
+
+
+ l.pi <- l_layer_polygon(p, x=c(xr, rev(xr)),
+ y=c(yp[,2],rev(yp[,3])),
+ color="lightgreen",
+ linecolor= "darkgreen", linewidth=2,
+ label="predition interval west liguria")
+
+ l.fit <- l_layer_line(p, x=xr, y=yp[,1],
+ color="darkgreen", linewidth=8,
+ label="fit west liguria")
+
+ l_layer_move(p, l.pi, "root", "end")
+ l_layer_raise(p, l.pi)
+
+
+ ## Text (size does not work and color is gray)
+
+ readline("press the return key to continue: next layer text")
+
+ bbox <- l_layer_bbox(p, "root")
+
+ l_layer_texts(p, x=seq(from=bbox[1], to=bbox[3], length.out=length(LETTERS)),
+ y=rev(seq(from=bbox[2], to=bbox[4], length.out=length(LETTERS))),
+ text=LETTERS, size=seq_along(LETTERS),
+ angle=seq_along(LETTERS)/length(LETTERS)*360)
+
+ })
press the return key to continue: next add points layer
press the return key to continue: next scale to world
press the return key to continue: next configure size and color
press the return key to continue: next re-initialize points
press the return key to continue: next re-label and move layer
press the return key to continue: next layer a polygon
press the return key to continue: next layer a rectangle
press the return key to continue: next layer an oval
press the return key to continue: next layer a (regression) line and polygon
press the return key to continue: next layer text
loon layer "texts" of type texts of plot .l6.plot
[1] "layer7"
demo(l_layout)
---- ~~~~~~~~
> local({
+ ## Tk geometry managers like grid and pack may be used
+ ## to place the widgets
+
+ ## With pack stack three scatterplots that share the same x on top
+ ## and bind the zoomX and panX
+ tt <- tktoplevel()
+ tktitle(tt) <- "Using the pack geometry manager"
+
+ attach(iris)
+ p1 <- l_plot(parent=tt, x=Sepal.Width, y=Petal.Width, color=Species,
+ linkingGroup="iris", showLabels=FALSE)
+ p2 <- l_plot(parent=tt, x=Sepal.Width, y=Petal.Length,
+ linkingGroup="iris", showLabels=FALSE)
+ p3 <- l_plot(parent=tt, x=Sepal.Width, y=Sepal.Length,
+ linkingGroup="iris", showLabels=FALSE)
+ s <- l_serialaxes(parent=tt, iris[,-5], linkingGroup="iris",
+ axesLayout="parallel")
+
+ detach(iris)
+
+ ## make the canvas resize to fairly small
+
+ for (p in c(p1,p2,p3,s)) {
+ tkconfigure(paste(p,".canvas", sep=''), width=200, height=100)
+ }
+
+ tkpack(p1, p2, p3, s, fill="both", expand=TRUE)
+
+
+ ## Bind so that they show the same x range
+ l_bind_state(p1, c("panX", "zoomX"), function(W)updateZoomPan(W))
+ l_bind_state(p2, c("panX", "zoomX"), function(W)updateZoomPan(W))
+ l_bind_state(p3, c("panX", "zoomX"), function(W)updateZoomPan(W))
+
+ busy <- FALSE
+ updateZoomPan <- function(widget) {
+ if (!busy) {
+ busy <- TRUE
+ zoomX <- l_cget(widget, "zoomX")
+ panX <- l_cget(widget, "panX")
+
+ for (w in c(p1, p2, p3)) {
+ l_configure(w, panX=panX, zoomX=zoomX, zoomY=zoomX)
+ }
+
+ busy <- FALSE
+ }
+ }
+
+
+ readline("press the return key to continue: next scatterplot matrix with grid")
+
+ tt2 <- tktoplevel()
+ tktitle(tt2) <- "Scatterplot Maxtrix Using Grid"
+
+ nvar <- 7
+ pair <- combn(3:10, 2)
+
+ ## create plots
+ plots <- apply(pair, 2, function(col) {
+ l_plot(parent=tt2, olive[,col[2]], olive[,col[1]], showLabels=FALSE)
+ })
+
+ ## resize the min canvas size
+ sapply(plots, function(p) {
+ tkconfigure(paste(p,'.canvas',sep=''), width=50, height=50)
+ })
+
+ ## grid layout
+ apply(rbind(plots, pair-2), 2, function(col) {
+ tkgrid(col[1], row=col[2], column=col[3], sticky="nesw")
+ })
+
+ ## Column and Row wheight such that the cells expand
+ for (i in 1:(nvar+1)) {
+ tkgrid.columnconfigure(tt2, i, weight = 1)
+ tkgrid.rowconfigure(tt2, i, weight = 1)
+ }
+
+ ## Add Variable Label
+ for (i in 3:10) {
+ lab <- tklabel(tt2, text=names(olive)[i])
+ tkgrid(lab, row = i - 2, column = i - 2)
+ }
+
+ ## Link Plots and specify color
+ ## sync=push is cheaper
+ sapply(plots, function(p)l_configure(p, linkingGroup="olive", sync="push"))
+
+ l_configure(plots[1], color=olive$Area)
+
+
+
+ })
press the return key to continue: next scatterplot matrix with grid
demo(l_linkPrimitiveGlyphs)
---- ~~~~~~~~~~~~~~~~~~~~~
> ## The suported point glyph primitives are: circle, square, triangle,
> ## and rhombus. These glyphs are available for every scatterplot.
> ##
> ## So a call
> ##
> ## p['glyph'] <- "rhombus"
> ##
> ## will change every point glyph to a rhombus.
> ##
> ## Generally glyphs can not be linked among scatterplots, as nothing
> ## guarantees that a particular (image, text, boxplot, etc...) glyph
> ## is available for a scatterplot. However primitive shapes can be
> ## linked, but it must be done manually as this demo shows.
> ##
> ## An simpler way, but less secure, is to set glyph to be a linked
> ## state:
> ##
> ## states <- c(l_getLinkedStates(p1), 'glyph')
> ## l_setLinkedStates(p1, states)
> ## l_setLinkedStates(p2, states)
>
>
> local({
+
+ p1 <- with(iris,
+ l_plot(Sepal.Length, Petal.Width, color=Species,
+ linkingGroup="iris"))
+ p2 <- with(iris,
+ l_plot(Petal.Length, Sepal.Width, color=Species,
+ linkingGroup="iris"))
+
+ l_bind_state(p1, "glyph", function(W)syncglyphs(W))
+ l_bind_state(p2, "glyph", function(W)syncglyphs(W))
+
+
+ tosync <- c(p1, p2)
+
+ isbusy <- FALSE
+ syncglyphs <- function(widget) {
+ if (isbusy) {return()}
+
+ glyph <- l_cget(widget, "glyph")
+ if (any(!(glyph %in% c("circle", "square",
+ "triangle", "diamond", "ocircle",
+ "osquare", "otriangle", "odiamond")))) {
+ stop(paste("Widget", widget,
+ "has a glyph that is not a primitive glyph shape."))
+ }
+
+ isbusy <- TRUE
+ for(p in tosync) {
+ if (p != widget) {
+ l_configure(p, glyph=glyph)
+ }
+ }
+ isbusy <- FALSE
+ }
+
+
+ })
demo(l_linking)
---- ~~~~~~~~~
> local({
+
+ p1 <- with(trees,
+ l_plot(Girth, Height, linkingGroup="trees"))
+
+ p2 <- with(trees,
+ l_plot(Height, Volume, linkingGroup="trees"))
+
+ p3 <- with(trees,
+ l_plot(Girth, Volume, color="red"))
+
+ l_configure(p3, linkingGroup="trees", sync="push")
+
+ readline("press the return key to continue: next disable linking of color for p3")
+
+ l_getLinkedStates(p3)
+ l_setLinkedStates(p3, c("active", "size", "selected"))
+
+ readline("press the return key to continue: next add serialaxes plot")
+
+ s <- l_serialaxes(trees, linkingGroup="trees")
+
+ readline("press the return key to continue: next demonstrate linkingKey")
+
+ p4 <- l_plot(1:9,1:9, color="orange",
+ linkingKey=LETTERS[2:10], linkingGroup="letters")
+ g4.t <- l_glyph_add_text(p4, text=LETTERS[2:10])
+ l_configure(p4, glyph=g4.t, size=10)
+
+
+ p5 <- l_plot(1:4,1:4, color="green",
+ linkingKey=LETTERS[5:8], linkingGroup="letters")
+ g5.t <- l_glyph_add_text(p5, text=LETTERS[5:8])
+ l_configure(p5, glyph=g5.t, size=10)
+
+ })
press the return key to continue: next disable linking of color for p3
press the return key to continue: next add serialaxes plot
press the return key to continue: next demonstrate linkingKey
demo(l_map)
---- ~~~~~
> require(maps) || stop("package maps needed.")
Loading required package: maps
[1] TRUE
> local({
+
+ ## Maps from the map library
+ canada <- map("world", "Canada", fill=TRUE, plot=FALSE)
+ pmap <- l_plot()
+
+ ## Color the lakes
+ id <- l_layer(pmap, canada,
+ color = ifelse(grepl("lake", canada$names,
+ ignore.case=TRUE), "lightblue", ""), asSingleLayer=FALSE)
+ l_scaleto_layer(pmap, id)
+
+ ## Or manually
+ ##l_layer(pmap, target='layer69', color="lightblue") # Lake Winnipeg
+ ##l_layer(pmap, target='layer33', color="lightblue") # Great Slave Lake
+ ##l_layer(pmap, target='layer15', color="lightblue") # Great Bear Lake
+
+ readline("press the return key to continue: next add points to scatterplot")
+
+ data(world.cities)
+ canada.cities <- subset(world.cities,
+ grepl("canada", country.etc , ignore.case=TRUE))
+
+ with(canada.cities,
+ l_configure(pmap, x=long, y=lat))
+ l_scaleto_world(pmap)
+
+ readline("press the return key to continue: next add city name glyphs")
+
+ g.t <- l_glyph_add_text(pmap, text=canada.cities$name)
+ pmap['glyph'] <- g.t
+
+ })
press the return key to continue: next add points to scatterplot
press the return key to continue: next add city name glyphs
demo(l_map_sp)
---- ~~~~~~~~
> require(sp) || stop("package sp qequired")
Loading required package: sp
[1] TRUE
> local({
+
+ if (FALSE) {
+ con <- url("http://biogeo.ucdavis.edu/data/gadm2/R/CHE_adm0.RData")
+ load(con)
+ close(con)
+
+ p <- l_plot()
+ g <- l_layer_group(p, label="Switzerland")
+ m <- l_layer(p, gadm, label="Switzerland", parent=g,
+ color="", linecolor="black")
+ l_scaleto_world(p)
+
+ readline("press the return key to continue: map with multiple layers")
+
+ l_layer_hide(p, g)
+
+ g1 <- l_layer_group(p, label="Swiss Cantons")
+
+ con <- url("http://biogeo.ucdavis.edu/data/gadm2/R/CHE_adm1.RData")
+ load(con)
+ close(con)
+
+ m1 <- l_layer(p, gadm, label="Swiss Cantons", parent=g1,
+ color="", linecolor="red")
+
+ # ## name the layers
+ cantons <- gadm@data$NAME_1[gadm@plotOrder]
+
+ for (i in 1:length(m1)) {
+ sapply(m1[[i]], function(l)l_layer_relabel(p, l, cantons[i]))
+ }
+
+ } else {
+ cat(paste0('loon demo l_map_sp should be evaluated by hand\nFind the demo file at: ',
+ system.file('demo','l_map_sp.R', package='loon'),'\n'))
+ }
+ ## l_aspect(p) <- 5/3
+
+ })
loon demo l_map_sp should be evaluated by hand
Find the demo file at: /data/gannet/ripley/R/packages/tests-clang/loon.Rcheck/loon/demo/l_map_sp.R
demo(l_ng_dimred)
---- ~~~~~~~~~~~
> require(MASS) || stop("MASS library required")
Loading required package: MASS
[1] TRUE
> require(kernlab) || stop("kernlab library required")
Loading required package: kernlab
[1] TRUE
> require(RDRToolbox) || stop("RDRToolbox library required")
Loading required package: RDRToolbox
Error in eval(ei, envir) : RDRToolbox library required
Calls: demo -> source -> withVisible -> eval -> eval
In addition: Warning message:
In library(package, lib.loc = lib.loc, character.only = TRUE, logical.return = TRUE, :
there is no package called 'RDRToolbox'
Execution halted
Flavor: r-devel-linux-x86_64-fedora-clang
Version: 1.1.0
Check: tests
Result: ERROR
Running ‘demos.R’ [21s/24s]
Running ‘testthat.R’
Running the tests in ‘tests/demos.R’ failed.
Complete output:
> ## as in the rgl package
>
> library(loon)
Loading required package: tcltk
>
> # options(demo.ask=FALSE)
>
> is_windows <- Sys.info()['sysname'] == "Windows"
>
> for(demo in demo(package="loon")$results[,"Item"]) {
+ if (!(demo %in% c("loon", "lsystem"))) {
+ # on windows all the image resizing seem to use up too much memory
+ # when all the demos are run sequentially
+ if (!(is_windows && grepl("^l_ng_", demo))) {
+ demo(demo, package="loon", character.only=TRUE)
+ }
+ }
+ }
demo(l_add_regressions)
---- ~~~~~~~~~~~~~~~~~
> # Define a function addRegressionLines that takes a scatterplot
> # handle as argument and creates a GUI to fit regression lines
> # of a specific order to the selected points
>
> local({
+
+ addRegressionLinesGUI <- function(p) {
+ force(p)
+ addRegressionLine <- function() {
+ sel <- p['selected']
+ if (sum(sel)==0) return()
+ xs <- p['x'][sel]; ys <- p['y'][sel]
+ fit <- lm(ys ~ poly(xs, as.numeric(tclvalue(degree))))
+ xrng <- seq(min(xs), max(xs), length.out = 20)
+ ypred <- predict(fit, newdata=data.frame(xs = xrng))
+ l_layer_line(p, x=xrng, y=ypred, color=as.character(color),
+ linewidth = 4, index=0, label=paste("degree", tclvalue(degree)))
+ l_configure(p, color=color, glyph='ocircle', which=sel)
+ }
+
+ updateColor <- function() {
+ col <- as.character(tcl('tk_chooseColor', initialcolor=color))
+ if (col!='') {
+ tkconfigure(b_col, bg=col, activebackground=col)
+ color <<- col
+ }
+ }
+
+ tt <- tktoplevel()
+ tktitle(tt) <- 'Add Regression Line'
+ degree <- tclVar('1')
+ color <- 'red'
+ s <- tkscale(tt, orient='horizontal', variable=degree,
+ from=1, to=8, resolution=1)
+ b_col <- tkbutton(tt, bg=color, activebackground=color, command=updateColor)
+ b_add <- tkbutton(tt, text='add', command=addRegressionLine)
+ tkgrid(tklabel(tt, text='degree:'), s, b_col, b_add, sticky='s', pady=5)
+ tkgrid.columnconfigure(tt, 1, weight=1)
+ tkgrid.configure(s, sticky='ew')
+ }
+
+
+ ## For example, for generated data
+ x <- runif(500)*7
+ y <- sapply(x, function(x) {
+ if (0 <= x && x < 2) {
+ 5*x + rnorm(1,0,1)
+ } else if (2 <= x && x < 5) {
+ 8.6 + 2*x-.6*x^2 + rnorm(1,0,.5)
+ } else {
+ 8.5 - log(x) + rnorm(1,0,.8)
+ }
+ })
+
+ p <- l_plot(x,y)
+ addRegressionLinesGUI(p)
+ })
<Tcl>
demo(l_glyph_sizes)
---- ~~~~~~~~~~~~~
> require(RnavGraphImageData) || stop("Neeed RnavGraphImageData package")
Loading required package: RnavGraphImageData
[1] TRUE
> if (loon:::.withTclImg) {
+ local({
+ # Plot glyphsizes for different glyphs
+ sizes <- c(0:10) # seq(15,25,by=5)
+ ns <- length(sizes)
+
+ glyphs <- c('sizes', 'circle', 'square', 'triangle', 'diamond',
+ 'text', 'image', 'stars', 'parallel', 'polygon')
+ ng <- length(glyphs)
+
+ ## ns+1 for labels
+ x <- rep(1:(ns+1), ng)
+ y <- rep(c(9, 8, 7.5, 7, 6.5, 6, 5, 3, 1,-1), each=ns+1)
+
+ p <- l_plot(x,y, showLabels=FALSE)
+
+
+ for (i in seq_along(glyphs)) {
+ assign(paste0('i_',glyphs[i]), seq((i-1)*(ns+1)+1,i*(ns+1)))
+ }
+
+
+ ## Size Labels
+ labelsize <- 6
+ psizes <- rep(c(labelsize, sizes), ng)
+
+ c_psizes <- as.character(psizes)
+ c_psizes[c_psizes=="0"] <- "<1"
+
+ g_sizes <- l_glyph_add_text(p, text = c_psizes, label="size labels")
+
+ p['glyph'] <- g_sizes
+ p['size'] <- psizes
+
+ l_configure(p, color='black', size=labelsize, which=i_sizes)
+
+ ## Primitive Glyphs
+ l_configure(p, glyph='circle', which=i_circle)
+ l_configure(p, glyph='square', which=i_square)
+ l_configure(p, glyph='triangle', which=i_triangle)
+ l_configure(p, glyph='diamond', which=i_diamond)
+
+
+ ## text glyph
+ g_text <- l_glyph_add_text(p, text = rep("aA", p['n']), label='text glyphs')
+ l_configure(p, glyph=g_text, which=i_text)
+
+
+ ## Images
+ data(faces)
+ faces.imgs <- l_image_import_array(faces, 64, 64, img_in_row = FALSE)
+ faces.imgs[1]
+ g_image <- l_glyph_add_image(p, image=rep(faces.imgs[1], p['n']), label='frey faces')
+ l_configure(p, glyph=g_image, which=i_image)
+
+
+ ## Stars
+ g_stars <- l_glyph_add_serialaxes(p, data=oliveAcids,
+ label='star glyphs', showArea=FALSE,
+ showAxes = TRUE, showEnclosing = TRUE)
+ l_configure(p, glyph=g_stars, which=i_stars)
+
+ ## Parallel
+ g_parallel <- l_glyph_add_serialaxes(p, data=oliveAcids,
+ label='parallel coords', linewidth = 3, axesLayout = 'parallel',
+ showAxes = TRUE, showEnclosing = TRUE, showArea=FALSE)
+ l_configure(p, glyph=g_parallel, which=i_parallel)
+
+
+ # Polygons
+ # hand drawn
+ airplane_coords <- c(30.8,0.5,57.4,27.1,85.6,16.5,89.9,17,78.7,30.9,183.5,27.7,
+ 223.5,6.4,234.6,7.4,222.9,22.3,240,21.8,253.8,26.1,264.5,
+ 33.5,276.2,39.4,283.1,42,286.5,50.6,282,57.5,273.5,63.9,
+ 260.2,69.7,246.9,72.4,217.1,76.1,176.6,78.8,151.6,78.8,
+ 88.8,105.9,62.7,95.8,117,70.8,87.7,70.8,73.9,68.1,56.3,
+ 63.3,44.6,53.2,20.7,61.2,11.6,57.5,34,44.2)
+ x_ap <- airplane_coords[seq(1, length(airplane_coords), by=2)]
+ y_ap <- airplane_coords[seq(2, length(airplane_coords), by=2)]
+ ## center-scale
+ d_ap <- diff(range(x_ap, y_ap))/5 # 5 is min width or height of airplane if size <= 1
+ x_aps <- (x_ap-mean(x_ap))/d_ap
+ y_aps <- (y_ap-mean(y_ap))/d_ap
+
+ g_polygon <- l_glyph_add_polygon(p, x=lapply(seq_len(p['n']), function(arg) x_aps),
+ y = lapply(seq_len(p['n']), function(arg) y_aps),
+ label='airplane')
+ l_configure(p, glyph=g_polygon, which=i_polygon)
+
+
+ ## Row Labels
+ vapply(glyphs, function(g) {
+ get(paste0('i_', g))[1]
+ }, numeric(1))## Row labeling
+
+ g_row <- l_glyph_add_text(p, text=rep(glyphs, each= ns+1), label='glyph labels')
+
+ i_rowlabels <- vapply(glyphs, function(g) {
+ get(paste0('i_', g))[1]
+ }, numeric(1))
+
+ l_configure(p, glyph=g_row, color='black', which=i_rowlabels)
+
+ })
+ } else {
+ cat("need the tkimg tcl extension installed to run this demo.\n")
+ }
need the tkimg tcl extension installed to run this demo.
demo(l_glyphs)
---- ~~~~~~~~
> require(PairViz) || stop("Package PairViz is required.")
Loading required package: PairViz
Loading required package: TSP
Loading required package: gtools
Loading required package: graph
Loading required package: BiocGenerics
Loading required package: parallel
Attaching package: 'BiocGenerics'
The following objects are masked from 'package:parallel':
clusterApply, clusterApplyLB, clusterCall, clusterEvalQ,
clusterExport, clusterMap, parApply, parCapply, parLapply,
parLapplyLB, parRapply, parSapply, parSapplyLB
The following objects are masked from 'package:stats':
IQR, mad, sd, var, xtabs
The following objects are masked from 'package:base':
Filter, Find, Map, Position, Reduce, anyDuplicated, append,
as.data.frame, basename, cbind, colMeans, colSums, colnames,
dirname, do.call, duplicated, eval, evalq, get, grep, grepl,
intersect, is.unsorted, lapply, lengths, mapply, match, mget,
order, paste, pmax, pmax.int, pmin, pmin.int, rank, rbind,
rowMeans, rowSums, rownames, sapply, setdiff, sort, table, tapply,
union, unique, unsplit, which, which.max, which.min
Attaching package: 'graph'
The following object is masked from 'package:loon':
complement
[1] TRUE
> local({
+ p <- with(olive, l_plot(oleic~arachidic, color=Area))
+
+ ## Text
+ readline("press the return key to continue: next are text glyphs")
+
+ gt <- l_glyph_add_text(p, text=as.character(olive$Area))
+ p['glyph'] <- gt
+
+ ## Images
+
+ if (loon:::.withTclImg) {
+
+ readline("press the return key to continue: next are image glyphs")
+
+ path <- file.path(find.package(package = "loon"), "images")
+ files <- list.files(path, full.names=TRUE)
+ imgs <- l_image_import_files(files)
+ names(imgs) <- gsub("\\.png$", "", basename(names(imgs)))
+ area <- gsub("^.*-", "", as.character(olive$Area))
+ areaimages <- imgs[match(area, names(imgs))]
+ gi <- l_glyph_add_image(p, images=areaimages)
+ p['glyph'] <- gi
+
+
+ readline("press the return key to continue: next reuse single image")
+
+ l_configure(c(p,gi), images=areaimages[1])
+ ## or also just
+ ## l_configure(gi, images=areaimages[1])
+ }
+
+
+ ## Serialaxes
+ readline("press the return key to continue: next star glyphs")
+
+ sa <- l_glyph_add_serialaxes(p, data=oliveAcids)
+ l_configure(p, glyph=sa)
+
+ readline("press the return key to continue: next configure stars")
+
+ l_configure(sa, showEnclosing=FALSE, linewidth=2)
+ l_configure(sa, showArea=FALSE)
+
+ readline("press the return key to continue: next stack all Umbria glyphs")
+
+ p['selected'] <- olive$Area == "Umbria"
+ l_move_valign(p,'selected')
+ l_move_halign(p,'selected')
+ l_configure(p, size=40, which='selected')
+ l_scaleto_selected(p)
+ l_configure(sa, showEnclosing=TRUE, bboxColor="steelblue", showArea=FALSE)
+ p['selected'] <- FALSE
+
+ readline("press the return key to continue: next parallel coordinates")
+
+ l_move_reset(p)
+ p['size'] <- 4
+ l_scaleto_world(p)
+ l_configure(sa, axesLayout="parallel")
+
+ readline("press the return key to continue: next change the sequence")
+
+ l_configure(sa, sequence=as.vector(t(hpaths(names(olive)[-c(1,2)]))))
+
+ readline("press the return key to continue: next show axes")
+
+ l_configure(sa, showAxes=TRUE)
+
+ readline("press the return key to continue: switch back to star glyphs")
+
+ l_configure(sa, axesLayout="radial", showAxes=FALSE, showEnclosing=FALSE)
+
+
+ ## Polygon Glyphs
+ readline("press the return key to continue: add polygon glyphs")
+
+ x_star <-
+ c(-0.000864304235090734, 0.292999135695765, 0.949870354364736,
+ 0.474503025064823, 0.586862575626621, -0.000864304235090734,
+ -0.586430423509075, -0.474070872947277, -0.949438202247191, -0.29256698357822)
+ y_star <-
+ c(-1, -0.403630077787381, -0.308556611927398, 0.153846153846154,
+ 0.808556611927398, 0.499567847882455, 0.808556611927398, 0.153846153846154,
+ -0.308556611927398, -0.403630077787381)
+ x_cross <-
+ c(-0.258931143762604, -0.258931143762604, -0.950374531835206,
+ -0.950374531835206, -0.258931143762604, -0.258931143762604, 0.259651397291847,
+ 0.259651397291847, 0.948934024776722, 0.948934024776722, 0.259651397291847,
+ 0.259651397291847)
+ y_cross <-
+ c(-0.950374531835206, -0.258931143762604, -0.258931143762604,
+ 0.259651397291847, 0.259651397291847, 0.948934024776722, 0.948934024776722,
+ 0.259651397291847, 0.259651397291847, -0.258931143762604, -0.258931143762604,
+ -0.950374531835206)
+ x_hexagon <-
+ c(0.773552290406223, 0, -0.773552290406223, -0.773552290406223,
+ 0, 0.773552290406223)
+ y_hexagon <-
+ c(0.446917314894843, 0.894194756554307, 0.446917314894843, -0.447637568424085,
+ -0.892754249495822, -0.447637568424085)
+
+
+ x_polygon_glyph <- lapply(as.character(olive$Region), function(region) {
+ if (region == "North")
+ x_cross
+ else if (region == "South")
+ x_star
+ else
+ x_hexagon
+ })
+
+ y_polygon_glyph <- lapply(as.character(olive$Region), function(region) {
+ if (region == "North")
+ y_cross
+ else if (region == "South")
+ y_star
+ else
+ y_hexagon
+ })
+
+ gl_pol <- l_glyph_add_polygon(p, x=x_polygon_glyph, y=y_polygon_glyph, label="polygon")
+
+ p['glyph'] <- gl_pol
+
+ readline("press the return key to continue: don't fill polygon glyph area")
+
+ gl_pol['showArea'] <- FALSE
+
+ ## Mix glyphs
+ readline("press the return key to continue: mix between different glyphs")
+
+ g <- sample(
+ c(
+ 'circle', 'square', 'triangle', 'diamond',
+ 'ocircle', 'osquare', 'otriangle', 'odiamond',
+ gt,
+ if (loon:::.withTclImg) gi else NULL,
+ sa, gl_pol
+ ),
+ dim(olive)[1], replace=TRUE
+ )
+ p['glyph'] <- g
+
+ ## Pointrange Glyphs
+ readline("press the return key to continue: next pointrange glyphs")
+
+ avg <- with(chickwts, tapply(weight, feed, mean))
+ sd <- with(chickwts, tapply(weight, feed, sd))
+
+ min <- with(chickwts, tapply(weight, feed, min))
+ max <- with(chickwts, tapply(weight, feed, max))
+
+ p1 <- l_plot(avg~sd)
+ g.p <- l_glyph_add_pointrange(p1, ymin=min, ymax=max)
+
+ p1['glyph'] <- g.p
+
+ })
press the return key to continue: next are text glyphs
press the return key to continue: next star glyphs
press the return key to continue: next configure stars
press the return key to continue: next stack all Umbria glyphs
press the return key to continue: next parallel coordinates
press the return key to continue: next change the sequence
press the return key to continue: next show axes
press the return key to continue: switch back to star glyphs
press the return key to continue: add polygon glyphs
press the return key to continue: don't fill polygon glyph area
press the return key to continue: mix between different glyphs
press the return key to continue: next pointrange glyphs
demo(l_knn)
---- ~~~~~
> local({
+
+ highlight_knn <- function(p, data, k=5, method='euclidean') {
+
+ if(!is(data, 'data.frame'))
+ data <- as.data.frame(data)
+
+ ## Create Custom Control Panel
+ tt <- tktoplevel()
+
+ onOff <- tclVar('1')
+ tkgrid(tkcheckbutton(tt, text='on/off', variable=onOff), sticky='w')
+
+ k <- tclVar(k)
+ f1 <- tkframe(tt)
+
+ e <- tkentry(f1, width=3, textvariable=k)
+ tkbind(e, '<Return>', function()hNN())
+ tkgrid(f1, sticky='w')
+ tkpack(tklabel(f1, text='k='), e, side='left')
+
+ tkgrid(tklabel(tt, text='Nearest to:'), sticky='w')
+ distFrom <- tclVar('points')
+ f2 <- tkframe(tt)
+ tkgrid(f2, sticky='w')
+ tkpack(tkradiobutton(f2, text='points', variable=distFrom,
+ value='points', command=function()hNN()),
+ tkradiobutton(f2, text='mean', variable=distFrom,
+ value='mean', command=function()hNN()),
+ side='left')
+
+ tkgrid(tklabel(tt, text='Space:'), sticky='w')
+ chbtns <- lapply(names(data), function(name) {
+ bvar <- tclVar('1')
+ b <- tkcheckbutton(tt, text=name, variable=bvar,
+ command=function()hNN())
+ tkgrid(b, sticky='w', padx=2)
+ return(bvar)
+ })
+
+
+ ## Create Nearest neighbour highlighting Functionality
+
+ if(!is(p, 'loon'))
+ class(p) <- "loon"
+
+ n <- nrow(data)
+ ## Which variables are used for D
+ cachedSpaceSelection <- rep(TRUE, ncol(data))
+ D <- as.matrix(dist(data, method = method))
+ I <- matrix(rep(1:n, n), ncol=n, byrow=TRUE)
+
+ inds <- 1:n # used for subsetting
+
+ ## Cache point gyph attributes that are used for highlighting
+ glyphCache <- character(0)
+ whichCache <- integer(0)
+ sizeCache <- integer(0)
+
+ ## Function that highlights nearest neighbours
+ hNN <- function() {
+
+ ## reset cached point glyphs attributes
+ if (length(whichCache) > 0) {
+ l_configure(p, glyph=glyphCache, size=sizeCache, which=whichCache)
+ whichCache <<- integer(0)
+ }
+
+ if (tclvalue(onOff) == '0') return()
+
+ isel <- which(p['selected'])
+ if (length(isel) == 0 || length(isel) == n) return()
+
+ spaceSelection <- vapply(chbtns,
+ function(b)as.logical(as.numeric(tclvalue(b))),
+ logical(1))
+
+ if(tclvalue(distFrom)=='points') {
+ if(!identical(cachedSpaceSelection, spaceSelection)) {
+ D <<- as.matrix(dist(data[, spaceSelection]))
+ cachedSpaceSelection <<- spaceSelection
+ }
+ chng_which <- unique(c(I[isel, -isel])[order(c(D[isel, -isel]))])
+ } else {
+ p_mean <- apply(data[isel, spaceSelection], 2, mean)
+ d <- apply(data[-isel, spaceSelection], 1,
+ function(row) dist(rbind(row, p_mean)))
+
+ chng_which <- (inds[-isel])[order(d)]
+ }
+
+ kval <- tclvalue(k)
+ if (grepl('[[:digit:]]+', kval)) {
+ kval <- as.numeric(kval)
+ } else {
+ kval <- 5
+ }
+
+ ksel <- min(length(chng_which),kval)
+
+ whichCache <<- chng_which[1:ksel]
+ glyphCache <<- p['glyph'][whichCache]
+ sizeCache <<- p['size'][whichCache]
+ l_configure(p, glyph='csquare', size=seq(25, 8, length.out = ksel), which=whichCache)
+ }
+
+ l_bind_state(p, 'selected', hNN)
+ }
+
+ ## For example,
+ sOiveAcids <- data.frame(scale(oliveAcids))
+ p <- with(sOiveAcids, l_plot(oleic~stearic, color=olive$Area))
+ highlight_knn(p, data=sOiveAcids, k=5)
+
+ l_aspect(p) <- 1
+
+ readline("press the return key to continue: next in a navigation graph setting")
+
+ nav <- l_navgraph(oliveAcids, color=olive$Area)
+ highlight_knn(nav$plot, sOiveAcids)
+ l_aspect(nav$plot) <- 1
+
+
+ })
press the return key to continue: next in a navigation graph setting
demo(l_layers)
---- ~~~~~~~~
> local({
+ p <- with(olive,
+ l_plot(x=linoleic, y=oleic,
+ color=Region, title="Olive Data"))
+
+
+ ## Layer a Group
+ l.g <- l_layer_group(p, label="Drawings", parent="root", index="end")
+
+
+ ## Layer Points
+ readline("press the return key to continue: next add points layer")
+
+ l.pts <- l_layer_points(p,
+ x=c(200, 450, 1800),
+ y=c(6000, 8000, 7000),
+ color=c("green", "orange", "lightblue"),
+ parent=l.g)
+
+ l_scaleto_layer(p, l.pts)
+
+ readline("press the return key to continue: next scale to world")
+
+ l_scaleto_world(p)
+
+
+ readline("press the return key to continue: next configure size and color")
+
+ l_configure(l.pts, color="thistle", size=30)
+
+ readline("press the return key to continue: next re-initialize points")
+
+ l_configure(l.pts,
+ x=seq(from=200,to=1600, length.out=20),
+ y=seq(from=6000,to=8000, length.out=20),
+ color="steelblue", size=20:39)
+
+
+ readline("press the return key to continue: next re-label and move layer")
+
+ l_layer_relabel(p, l.pts, "Different Sizes")
+ l_layer_move(p, l.pts, parent="root")
+
+
+ ## Polygon
+
+ readline("press the return key to continue: next layer a polygon")
+
+ i <- with(olive, chull(linoleic, oleic))
+
+ x.hull <- olive$linoleic[i]
+ y.hull <- olive$oleic[i]
+
+ l_layer_polygon(p, x.hull, y.hull, color="thistle",
+ linecolor="black", linewidth=4, parent=l.g)
+
+
+ ## Rectangle
+
+ readline("press the return key to continue: next layer a rectangle")
+
+ l_layer_rectangle(p, x=c(1100, 1300), y=c(7600, 8300), linewidth=2)
+
+ ## Oval
+ readline("press the return key to continue: next layer an oval")
+
+ l_layer_oval(p, x=c(1500, 1750), y=c(7900, 8100),
+ color="", linecolor="orange", linewidth=4)
+
+ ## Line
+ readline("press the return key to continue: next layer a (regression) line and polygon")
+
+ x <- with(olive, linoleic[Region=="North"])
+ y <- with(olive, oleic[Region=="North"])
+
+ fit <- lm(y~x)
+ ##summary(fit)
+
+ xr <- seq(from=min(x), to=max(x), length.out=20)
+ yp <- predict(fit, data.frame(x=xr), interval="prediction")
+
+
+ l.pi <- l_layer_polygon(p, x=c(xr, rev(xr)),
+ y=c(yp[,2],rev(yp[,3])),
+ color="lightgreen",
+ linecolor= "darkgreen", linewidth=2,
+ label="predition interval west liguria")
+
+ l.fit <- l_layer_line(p, x=xr, y=yp[,1],
+ color="darkgreen", linewidth=8,
+ label="fit west liguria")
+
+ l_layer_move(p, l.pi, "root", "end")
+ l_layer_raise(p, l.pi)
+
+
+ ## Text (size does not work and color is gray)
+
+ readline("press the return key to continue: next layer text")
+
+ bbox <- l_layer_bbox(p, "root")
+
+ l_layer_texts(p, x=seq(from=bbox[1], to=bbox[3], length.out=length(LETTERS)),
+ y=rev(seq(from=bbox[2], to=bbox[4], length.out=length(LETTERS))),
+ text=LETTERS, size=seq_along(LETTERS),
+ angle=seq_along(LETTERS)/length(LETTERS)*360)
+
+ })
press the return key to continue: next add points layer
press the return key to continue: next scale to world
press the return key to continue: next configure size and color
press the return key to continue: next re-initialize points
press the return key to continue: next re-label and move layer
press the return key to continue: next layer a polygon
press the return key to continue: next layer a rectangle
press the return key to continue: next layer an oval
press the return key to continue: next layer a (regression) line and polygon
press the return key to continue: next layer text
loon layer "texts" of type texts of plot .l6.plot
[1] "layer7"
demo(l_layout)
---- ~~~~~~~~
> local({
+ ## Tk geometry managers like grid and pack may be used
+ ## to place the widgets
+
+ ## With pack stack three scatterplots that share the same x on top
+ ## and bind the zoomX and panX
+ tt <- tktoplevel()
+ tktitle(tt) <- "Using the pack geometry manager"
+
+ attach(iris)
+ p1 <- l_plot(parent=tt, x=Sepal.Width, y=Petal.Width, color=Species,
+ linkingGroup="iris", showLabels=FALSE)
+ p2 <- l_plot(parent=tt, x=Sepal.Width, y=Petal.Length,
+ linkingGroup="iris", showLabels=FALSE)
+ p3 <- l_plot(parent=tt, x=Sepal.Width, y=Sepal.Length,
+ linkingGroup="iris", showLabels=FALSE)
+ s <- l_serialaxes(parent=tt, iris[,-5], linkingGroup="iris",
+ axesLayout="parallel")
+
+ detach(iris)
+
+ ## make the canvas resize to fairly small
+
+ for (p in c(p1,p2,p3,s)) {
+ tkconfigure(paste(p,".canvas", sep=''), width=200, height=100)
+ }
+
+ tkpack(p1, p2, p3, s, fill="both", expand=TRUE)
+
+
+ ## Bind so that they show the same x range
+ l_bind_state(p1, c("panX", "zoomX"), function(W)updateZoomPan(W))
+ l_bind_state(p2, c("panX", "zoomX"), function(W)updateZoomPan(W))
+ l_bind_state(p3, c("panX", "zoomX"), function(W)updateZoomPan(W))
+
+ busy <- FALSE
+ updateZoomPan <- function(widget) {
+ if (!busy) {
+ busy <- TRUE
+ zoomX <- l_cget(widget, "zoomX")
+ panX <- l_cget(widget, "panX")
+
+ for (w in c(p1, p2, p3)) {
+ l_configure(w, panX=panX, zoomX=zoomX, zoomY=zoomX)
+ }
+
+ busy <- FALSE
+ }
+ }
+
+
+ readline("press the return key to continue: next scatterplot matrix with grid")
+
+ tt2 <- tktoplevel()
+ tktitle(tt2) <- "Scatterplot Maxtrix Using Grid"
+
+ nvar <- 7
+ pair <- combn(3:10, 2)
+
+ ## create plots
+ plots <- apply(pair, 2, function(col) {
+ l_plot(parent=tt2, olive[,col[2]], olive[,col[1]], showLabels=FALSE)
+ })
+
+ ## resize the min canvas size
+ sapply(plots, function(p) {
+ tkconfigure(paste(p,'.canvas',sep=''), width=50, height=50)
+ })
+
+ ## grid layout
+ apply(rbind(plots, pair-2), 2, function(col) {
+ tkgrid(col[1], row=col[2], column=col[3], sticky="nesw")
+ })
+
+ ## Column and Row wheight such that the cells expand
+ for (i in 1:(nvar+1)) {
+ tkgrid.columnconfigure(tt2, i, weight = 1)
+ tkgrid.rowconfigure(tt2, i, weight = 1)
+ }
+
+ ## Add Variable Label
+ for (i in 3:10) {
+ lab <- tklabel(tt2, text=names(olive)[i])
+ tkgrid(lab, row = i - 2, column = i - 2)
+ }
+
+ ## Link Plots and specify color
+ ## sync=push is cheaper
+ sapply(plots, function(p)l_configure(p, linkingGroup="olive", sync="push"))
+
+ l_configure(plots[1], color=olive$Area)
+
+
+
+ })
press the return key to continue: next scatterplot matrix with grid
demo(l_linkPrimitiveGlyphs)
---- ~~~~~~~~~~~~~~~~~~~~~
> ## The suported point glyph primitives are: circle, square, triangle,
> ## and rhombus. These glyphs are available for every scatterplot.
> ##
> ## So a call
> ##
> ## p['glyph'] <- "rhombus"
> ##
> ## will change every point glyph to a rhombus.
> ##
> ## Generally glyphs can not be linked among scatterplots, as nothing
> ## guarantees that a particular (image, text, boxplot, etc...) glyph
> ## is available for a scatterplot. However primitive shapes can be
> ## linked, but it must be done manually as this demo shows.
> ##
> ## An simpler way, but less secure, is to set glyph to be a linked
> ## state:
> ##
> ## states <- c(l_getLinkedStates(p1), 'glyph')
> ## l_setLinkedStates(p1, states)
> ## l_setLinkedStates(p2, states)
>
>
> local({
+
+ p1 <- with(iris,
+ l_plot(Sepal.Length, Petal.Width, color=Species,
+ linkingGroup="iris"))
+ p2 <- with(iris,
+ l_plot(Petal.Length, Sepal.Width, color=Species,
+ linkingGroup="iris"))
+
+ l_bind_state(p1, "glyph", function(W)syncglyphs(W))
+ l_bind_state(p2, "glyph", function(W)syncglyphs(W))
+
+
+ tosync <- c(p1, p2)
+
+ isbusy <- FALSE
+ syncglyphs <- function(widget) {
+ if (isbusy) {return()}
+
+ glyph <- l_cget(widget, "glyph")
+ if (any(!(glyph %in% c("circle", "square",
+ "triangle", "diamond", "ocircle",
+ "osquare", "otriangle", "odiamond")))) {
+ stop(paste("Widget", widget,
+ "has a glyph that is not a primitive glyph shape."))
+ }
+
+ isbusy <- TRUE
+ for(p in tosync) {
+ if (p != widget) {
+ l_configure(p, glyph=glyph)
+ }
+ }
+ isbusy <- FALSE
+ }
+
+
+ })
demo(l_linking)
---- ~~~~~~~~~
> local({
+
+ p1 <- with(trees,
+ l_plot(Girth, Height, linkingGroup="trees"))
+
+ p2 <- with(trees,
+ l_plot(Height, Volume, linkingGroup="trees"))
+
+ p3 <- with(trees,
+ l_plot(Girth, Volume, color="red"))
+
+ l_configure(p3, linkingGroup="trees", sync="push")
+
+ readline("press the return key to continue: next disable linking of color for p3")
+
+ l_getLinkedStates(p3)
+ l_setLinkedStates(p3, c("active", "size", "selected"))
+
+ readline("press the return key to continue: next add serialaxes plot")
+
+ s <- l_serialaxes(trees, linkingGroup="trees")
+
+ readline("press the return key to continue: next demonstrate linkingKey")
+
+ p4 <- l_plot(1:9,1:9, color="orange",
+ linkingKey=LETTERS[2:10], linkingGroup="letters")
+ g4.t <- l_glyph_add_text(p4, text=LETTERS[2:10])
+ l_configure(p4, glyph=g4.t, size=10)
+
+
+ p5 <- l_plot(1:4,1:4, color="green",
+ linkingKey=LETTERS[5:8], linkingGroup="letters")
+ g5.t <- l_glyph_add_text(p5, text=LETTERS[5:8])
+ l_configure(p5, glyph=g5.t, size=10)
+
+ })
press the return key to continue: next disable linking of color for p3
press the return key to continue: next add serialaxes plot
press the return key to continue: next demonstrate linkingKey
demo(l_map)
---- ~~~~~
> require(maps) || stop("package maps needed.")
Loading required package: maps
[1] TRUE
> local({
+
+ ## Maps from the map library
+ canada <- map("world", "Canada", fill=TRUE, plot=FALSE)
+ pmap <- l_plot()
+
+ ## Color the lakes
+ id <- l_layer(pmap, canada,
+ color = ifelse(grepl("lake", canada$names,
+ ignore.case=TRUE), "lightblue", ""), asSingleLayer=FALSE)
+ l_scaleto_layer(pmap, id)
+
+ ## Or manually
+ ##l_layer(pmap, target='layer69', color="lightblue") # Lake Winnipeg
+ ##l_layer(pmap, target='layer33', color="lightblue") # Great Slave Lake
+ ##l_layer(pmap, target='layer15', color="lightblue") # Great Bear Lake
+
+ readline("press the return key to continue: next add points to scatterplot")
+
+ data(world.cities)
+ canada.cities <- subset(world.cities,
+ grepl("canada", country.etc , ignore.case=TRUE))
+
+ with(canada.cities,
+ l_configure(pmap, x=long, y=lat))
+ l_scaleto_world(pmap)
+
+ readline("press the return key to continue: next add city name glyphs")
+
+ g.t <- l_glyph_add_text(pmap, text=canada.cities$name)
+ pmap['glyph'] <- g.t
+
+ })
press the return key to continue: next add points to scatterplot
press the return key to continue: next add city name glyphs
demo(l_map_sp)
---- ~~~~~~~~
> require(sp) || stop("package sp qequired")
Loading required package: sp
[1] TRUE
> local({
+
+ if (FALSE) {
+ con <- url("http://biogeo.ucdavis.edu/data/gadm2/R/CHE_adm0.RData")
+ load(con)
+ close(con)
+
+ p <- l_plot()
+ g <- l_layer_group(p, label="Switzerland")
+ m <- l_layer(p, gadm, label="Switzerland", parent=g,
+ color="", linecolor="black")
+ l_scaleto_world(p)
+
+ readline("press the return key to continue: map with multiple layers")
+
+ l_layer_hide(p, g)
+
+ g1 <- l_layer_group(p, label="Swiss Cantons")
+
+ con <- url("http://biogeo.ucdavis.edu/data/gadm2/R/CHE_adm1.RData")
+ load(con)
+ close(con)
+
+ m1 <- l_layer(p, gadm, label="Swiss Cantons", parent=g1,
+ color="", linecolor="red")
+
+ # ## name the layers
+ cantons <- gadm@data$NAME_1[gadm@plotOrder]
+
+ for (i in 1:length(m1)) {
+ sapply(m1[[i]], function(l)l_layer_relabel(p, l, cantons[i]))
+ }
+
+ } else {
+ cat(paste0('loon demo l_map_sp should be evaluated by hand\nFind the demo file at: ',
+ system.file('demo','l_map_sp.R', package='loon'),'\n'))
+ }
+ ## l_aspect(p) <- 5/3
+
+ })
loon demo l_map_sp should be evaluated by hand
Find the demo file at: /data/gannet/ripley/R/packages/tests-devel/loon.Rcheck/loon/demo/l_map_sp.R
demo(l_ng_dimred)
---- ~~~~~~~~~~~
> require(MASS) || stop("MASS library required")
Loading required package: MASS
[1] TRUE
> require(kernlab) || stop("kernlab library required")
Loading required package: kernlab
[1] TRUE
> require(RDRToolbox) || stop("RDRToolbox library required")
Loading required package: RDRToolbox
Error in eval(ei, envir) : RDRToolbox library required
Calls: demo -> source -> withVisible -> eval -> eval
In addition: Warning message:
In library(package, lib.loc = lib.loc, character.only = TRUE, logical.return = TRUE, :
there is no package called 'RDRToolbox'
Execution halted
Flavor: r-devel-linux-x86_64-fedora-gcc
Version: 1.1.0
Check: tests
Result: ERROR
Running ‘demos.R’ [14s/16s]
Running the tests in ‘tests/demos.R’ failed.
Last 13 lines of output:
Loading required package: MASS
[1] TRUE
> require(kernlab) || stop("kernlab library required")
Loading required package: kernlab
[1] TRUE
> require(RDRToolbox) || stop("RDRToolbox library required")
Loading required package: RDRToolbox
Error in eval(ei, envir) : RDRToolbox library required
Calls: demo -> source -> withVisible -> eval -> eval
In addition: Warning message:
In library(package, lib.loc = lib.loc, character.only = TRUE, logical.return = TRUE, :
there is no package called 'RDRToolbox'
Execution halted
Flavor: r-release-osx-x86_64
Version: 1.1.0
Check: whether package can be installed
Result: ERROR
Installation failed.
Flavor: r-oldrel-osx-x86_64