R Development Page

directlabels log file (check_x86_64_linux)

Mon Jun 28 17:08:50 2021: Checking package directlabels (SVN revision 688) ...
* using log directory ‘/srv/rf/building/build_2021-06-28-17-07/RF_PKG_CHECK/PKGS/directlabels.Rcheck’
* using R version 4.1.0 Patched (2021-06-26 r80566)
* using platform: x86_64-pc-linux-gnu (64-bit)
* using session charset: UTF-8
* using option ‘--as-cran’
* checking for file ‘directlabels/DESCRIPTION’ ... OK
* this is package ‘directlabels’ version ‘2020.6.17’
* checking CRAN incoming feasibility ... WARNING
Maintainer: ‘Toby Dylan Hocking ’

Insufficient package version (submitted: 2020.6.17, existing: 2021.1.13)
Version contains large components (2020.6.17)

Package has a VignetteBuilder field but no prebuilt vignette index.
* checking package namespace information ... OK
* checking package dependencies ... OK
* checking if this is a source package ... OK
* checking if there is a namespace ... OK
* checking for executable files ... OK
* checking for hidden files and directories ... OK
* checking for portable file names ... OK
* checking for sufficient/correct file permissions ... OK
* checking serialization versions ... OK
* checking whether package ‘directlabels’ can be installed ... [3s/3s] OK
* checking installed package size ... OK
* checking package directory ... OK
* checking for future file timestamps ... OK
* checking DESCRIPTION meta-information ... OK
* checking top-level files ... NOTE
Non-standard file/directory found at top level:
  ‘etc’
* checking for left-over files ... OK
* checking index information ... OK
* checking package subdirectories ... OK
* checking R files for non-ASCII characters ... OK
* checking R files for syntax errors ... OK
* checking whether the package can be loaded ... OK
* checking whether the package can be loaded with stated dependencies ... OK
* checking whether the package can be unloaded cleanly ... OK
* checking whether the namespace can be loaded with stated dependencies ... OK
* checking whether the namespace can be unloaded cleanly ... OK
* checking loading without being on the library search path ... OK
* checking use of S3 registration ... OK
* checking dependencies in R code ... OK
* checking S3 generic/method consistency ... OK
* checking replacement functions ... OK
* checking foreign function calls ... OK
* checking R code for possible problems ... [5s/5s] OK
* checking Rd files ... [0s/0s] OK
* checking Rd metadata ... WARNING
Rd files with duplicated alias 'directlabels':
  ‘direct.label.Rd’ ‘directlabels-package.Rd’
* checking Rd line widths ... OK
* checking Rd cross-references ... OK
* checking for missing documentation entries ... WARNING
Undocumented code objects:
  ‘bottom.points’ ‘bottom.polygons’ ‘left.points’ ‘left.polygons’
  ‘pkgFun’ ‘reduce.cex’ ‘reduce.cex.tb’ ‘right.points’ ‘right.polygons’
  ‘top.polygons’
All user-level objects in a package should have documentation entries.
See chapter ‘Writing R documentation files’ in the ‘Writing R
Extensions’ manual.
* checking for code/documentation mismatches ... OK
* checking Rd \usage sections ... OK
* checking Rd contents ... OK
* checking for unstated dependencies in examples ... OK
* checking contents of ‘data’ directory ... OK
* checking data for non-ASCII characters ... OK
* checking LazyData ... OK
* checking data for ASCII and uncompressed saves ... OK
* checking line endings in Makefiles ... OK
* checking for GNU extensions in Makefiles ... OK
* checking include directives in Makefiles ... OK
* checking examples ... [4s/4s] ERROR
Running examples in ‘directlabels-Ex.R’ failed
The error most likely occurred in:

> base::assign(".ptime", proc.time(), pos = "CheckExEnv")
> ### Name: direct.label
> ### Title: Direct labels for color decoding
> ### Aliases: direct.label directlabels
> 
> ### ** Examples
> 
> if(require(ggplot2)){
+   ## Add direct labels to a ggplot2 scatterplot, making sure that each
+   ## label is close to its point cloud, and doesn't overlap points or
+   ## other labels.
+   scatter <- qplot(jitter(hwy),jitter(cty),data=mpg,colour=class,
+                    main="Fuel efficiency depends on car size")
+   print(direct.label(scatter))
+ }
Loading required package: ggplot2
Called from: apply.method(x$method, cm.data, debug = x$debug, axes2native = x$axes2native)
Browse[1]> 
debug: attr(d, "orig.data") <- d
Browse[2]> ## direct labels for lineplots that do not overlap and do not go off
Browse[2]> ## the plot.
Browse[2]> library(nlme)

Attaching package: ‘nlme’

The following object is masked from ‘package:directlabels’:

    gapply

Browse[2]> library(lattice)
Browse[2]> oldopt <- lattice.options(panel.error=NULL)
Browse[2]> ratplot <-
+   xyplot(weight~Time|Diet,BodyWeight,groups=Rat,type='l',layout=c(3,1))
Browse[2]> ## Using the default Positioning Method (maxvar.qp), the labels are
Browse[2]> ## placed on the side which is most spread out, so in multipanel
Browse[2]> ## plots they sometimes end up on different sides.
Browse[2]> print(direct.label(ratplot))
Called from: apply.method(x$method, cm.data, debug = x$debug, axes2native = x$axes2native)
Browse[3]> ## To put them on the same side, just manually specify the
Browse[3]> ## Positioning Method.
Browse[3]> print(direct.label(ratplot,"last.qp")) 
Error in direct.label(ratplot, "last.qp") : object 'ratplot' not found
Calls: print ... drawDetails.dlgrob -> apply.method -> print -> direct.label
Browse[3]> 
debug: attr(d, "orig.data") <- d
Browse[4]> lattice.options(oldopt)
Error in lattice.options(oldopt) : object 'oldopt' not found
Calls: print ... drawDetails.dlgrob -> apply.method -> lattice.options
Browse[4]> 
debug: check.for.columns(d, columns.to.check)
Browse[4]> 
debug: if (!is.list(method)) method <- list(method)
Browse[4]> 
debug: method <- list(method)
Browse[4]> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv")
Browse[4]> base::cat("direct.label", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t")
Browse[4]> cleanEx()

detaching ‘package:lattice’, ‘package:nlme’, ‘package:ggplot2’

Browse[4]> nameEx("dl.combine")
Browse[4]> ### * dl.combine
Browse[4]> 
debug: isconst <- function() {
    m.var <- names(method)[1]
    !(is.null(m.var) || m.var == "")
}
Browse[4]> flush(stderr()); flush(stdout())
Browse[4]> 
debug: islist <- function() is.list(method[[1]])
Browse[4]> base::assign(".ptime", proc.time(), pos = "CheckExEnv")
Browse[4]> ### Name: dl.combine
Browse[4]> ### Title: Combine output of several methods
Browse[4]> ### Aliases: dl.combine
Browse[4]> 
debug: isref <- function() (!isconst()) && is.character(method[[1]])
Browse[4]> ### ** Examples
Browse[4]> 
debug: while (length(method)) {
    if (debug) 
        print(method[1])
    while (islist() || isref()) {
        if (islist()) {
            method <- c(method[[1]], method[-1])
        }
        else {
            if (length(method[[1]]) > 1) {
                warning("using first element of character vector")
                method[[1]] <- method[[1]][1]
            }
            method <- c(get(method[[1]]), method[-1])
        }
    }
    if (isconst()) 
        d[[names(method)[1]]] <- method[[1]]
    else {
        old <- d
        group.dfs <- split(d, d$groups)
        group.specific <- lapply(group.dfs, only.unique.vals)
        to.restore <- Reduce(intersect, lapply(group.specific, 
            names))
        d <- method[[1]](d, debug = debug, ...)
        if (length(d) == 0) {
            return(data.frame())
        }
        else {
            check.for.columns(d, columns.to.check)
            if ("groups" %in% names(d)) {
                to.restore <- to.restore[!to.restore %in% names(d)]
                for (N in to.restore) {
                  d[[N]] <- NA
                  group.vec <- paste(unique(d$groups))
                  for (g in group.vec) {
                    old.val <- group.specific[[g]][, N]
                    if (is.factor(old.val)) 
                      old.val <- paste(old.val)
                    d[d$groups == g, N] <- old.val
                  }
                }
            }
        }
        attr(d, "orig.data") <- if (is.null(attr(old, "orig.data"))) 
            old
        else attr(old, "orig.data")
    }
    if (debug) {
        print(d)
    }
    method <- method[-1]
}
Browse[4]> 
debug: if (debug) print(method[1])
Browse[4]> ## Simple example: label the start and endpoints
Browse[4]> library(nlme)

Attaching package: ‘nlme’

The following object is masked from ‘package:directlabels’:

    gapply

Browse[4]> library(lattice)
Browse[4]> ratplot <- xyplot(
+   weight~Time|Diet,BodyWeight,groups=Rat,type='l',layout=c(3,1))
Browse[4]> both <- dl.combine("first.points","last.points")
Browse[4]> rat.both <- direct.label(ratplot,"both")
Browse[4]> print(rat.both)
Called from: apply.method(x$method, cm.data, debug = x$debug, axes2native = x$axes2native)
Browse[5]> 
debug: attr(d, "orig.data") <- d
Browse[6]> ## same as repeated call to direct.label:
Browse[6]> rat.repeated <-
+   direct.label(direct.label(ratplot,"last.points"),"first.points")
Error in direct.label(ratplot, "last.points") : 
  object 'ratplot' not found
Calls: print ... drawDetails.dlgrob -> apply.method -> direct.label -> direct.label
Browse[6]> print(rat.repeated)
Error in print(rat.repeated) : object 'rat.repeated' not found
Calls: print ... drawDetails -> drawDetails.dlgrob -> apply.method -> print
Browse[6]> 
debug: check.for.columns(d, columns.to.check)
Browse[6]> ## same with ggplot2:
Browse[6]> if(require(ggplot2)){
+   rp2 <- qplot(
+     Time,weight,data=BodyWeight,geom="line",facets=.~Diet,colour=Rat)
+   print(direct.label(direct.label(rp2,"last.points"),"first.points"))
+   print(direct.label(rp2,"both"))
+ }
Loading required package: ggplot2
debug: rp2 <- qplot(Time, weight, data = BodyWeight, geom = "line", 
    facets = . ~ Diet, colour = Rat)
Browse[7]> 
debug: print(direct.label(direct.label(rp2, "last.points"), "first.points"))
Browse[7]> ## more complex example: first here is a function for computing the
Browse[7]> ## lasso path.
Browse[7]> mylars <- function
+ ## Least angle regression algorithm for calculating lasso solutions.
+ (x,
+  ## Matrix of predictor variables.
+  y,
+  ## Vector of responses.
+  epsilon=1e-6
+  ## If correlation < epsilon, we are done.
+  ){
+   xscale <- scale(x) # need to work with standardized variables
+   b <- rep(0,ncol(x))# coef vector starts at 0
+   names(b) <- colnames(x)
+   ycor <- apply(xscale,2,function(xj)sum(xj*y))
+   j <- which.max(ycor) # variables in active set, starts with most correlated
+   alpha.total <- 0
+   out <- data.frame()
+   while(1){## lar loop
+     xak <- xscale[,j] # current variables
+     r <- y-xscale%*%b # current residual
+     ## direction of parameter evolution
+     delta <- solve(t(xak)%*%xak)%*%t(xak)%*%r
+     ## Current correlations (actually dot product)
+     intercept <- apply(xscale,2,function(xk)sum(r*xk))
+     ## current rate of change of correlations
+     z <- xak%*%delta
+     slope <- apply(xscale,2,function(xk)-sum(z*xk))
+     ## store current values of parameters and correlation
+     out <- rbind(out,data.frame(variable=colnames(x),
+                                 coef=b,
+                                 corr=abs(intercept),
+                                 alpha=alpha.total,
+                                 arclength=sum(abs(b)),
+                                 coef.unscaled=b/attr(xscale,"scaled:scale")))
+     if(sum(abs(intercept)) < epsilon)#corr==0 so we are done
+       return(transform(out,s=arclength/max(arclength)))
+     ## If there are more variables we can enter into the regression,
+     ## then see which one will cross the highest correlation line
+     ## first, and record the alpha value of where the lines cross.
+     d <- data.frame(slope,intercept)
+     d[d$intercept<0,] <- d[d$intercept<0,]*-1
+     d0 <- data.frame(d[j[1],])# highest correlation line
+     d2 <- data.frame(rbind(d,-d),variable=names(slope))#reflected lines
+     ## Calculation of alpha for where lines cross for each variable
+     d2$alpha <- (d0$intercept-d2$intercept)/(d2$slope-d0$slope)
+     subd <- d2[(!d2$variable%in%colnames(x)[j])&d2$alpha>epsilon,]
+     subd <- subd[which.min(subd$alpha),]
+     nextvar <- subd$variable
+     alpha <- if(nrow(subd))subd$alpha else 1
+     ## If one of the coefficients would hit 0 at a smaller alpha
+     ## value, take it out of the regression and continue.
+     hit0 <- xor(b[j]>0,delta>0)&b[j]!=0
+     alpha0 <- -b[j][hit0]/delta[hit0]
+     takeout <- length(alpha0)&&min(alpha0) < alpha
+     if(takeout){
+       i <- which.min(alpha0)
+       alpha <- alpha0[i]
+     }
+     b[j] <- b[j]+alpha*delta ## evolve parameters
+     alpha.total <- alpha.total+alpha
+     ## add or remove a variable from the active set
+     j <- if(takeout)j[j!=which(names(i)==colnames(x))]
+          else c(j,which(nextvar==colnames(x)))
+   }
+ }
Browse[7]> 
Called from: apply.method(x$method, cm.data, debug = x$debug, axes2native = x$axes2native)
Browse[7]> ## Calculate lasso path, plot labels at two points: (1) where the
Browse[7]> ## variable enters the path, and (2) at the end of the path.
Browse[7]> if(require(lars)){
+   data(diabetes,envir=environment())
+   dres <- with(diabetes,mylars(x,y))
+   P <- xyplot(coef~arclength,dres,groups=variable,type="l")
+   mylasso <- dl.combine("lasso.labels", "last.qp")
+   plot(direct.label(P,"mylasso"))
+ }
Loading required package: lars
Loaded lars 1.2

debug: data(diabetes, envir = environment())
Browse[9]> 
debug: dres <- with(diabetes, mylars(x, y))
Browse[9]> 
Error in mylars(x, y) : could not find function "mylars"
Calls: print ... apply.method -> with -> with.default -> eval -> eval
Browse[7]> 
debug: attr(d, "orig.data") <- d
Browse[8]> 
debug: check.for.columns(d, columns.to.check)
Browse[8]> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv")
Browse[8]> base::cat("dl.combine", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t")
Browse[8]> cleanEx()

detaching ‘package:lars’, ‘package:ggplot2’, ‘package:lattice’,
  ‘package:nlme’

Browse[8]> nameEx("dl.move")
Browse[8]> ### * dl.move
Browse[8]> 
debug: if (!is.list(method)) method <- list(method)
Browse[8]> flush(stderr()); flush(stdout())
Browse[8]> 
debug: method <- list(method)
Browse[8]> base::assign(".ptime", proc.time(), pos = "CheckExEnv")
Browse[8]> ### Name: dl.move
Browse[8]> ### Title: Manually move a direct label
Browse[8]> ### Aliases: dl.move
Browse[8]> 
debug: isconst <- function() {
    m.var <- names(method)[1]
    !(is.null(m.var) || m.var == "")
}
Browse[8]> ### ** Examples
Browse[8]> 
debug: islist <- function() is.list(method[[1]])
Browse[8]> if(require(ggplot2)){
+   library(lattice)
+   scatter <- xyplot(jitter(cty)~jitter(hwy),mpg,groups=class,aspect=1)
+   dlcompare(list(scatter),
+             list("extreme.grid",
+                  `+dl.move`=list(extreme.grid,dl.move("suv",15,15))))
+   p <- qplot(log10(gamma),rate,data=svmtrain,group=data,colour=data,
+              geom="line",facets=replicate~nu)
+   adjust.kif <- dl.move("KIF11",-0.9,hjust=1,vjust=1)
+   dlcompare(list(p+xlim(-8,7)),
+             list("last.points",
+                  `+dl.move`=list(last.points,adjust.kif)))
+ }
Loading required package: ggplot2
debug: library(lattice)
Browse[9]> 
debug: scatter <- xyplot(jitter(cty) ~ jitter(hwy), mpg, groups = class, 
    aspect = 1)
Browse[9]> 
debug: dlcompare(list(scatter), list("extreme.grid", `+dl.move` = list(extreme.grid, 
    dl.move("suv", 15, 15))))
Browse[9]> 
Called from: apply.method(x$method, cm.data, debug = x$debug, axes2native = x$axes2native)
Browse[9]> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv")
Browse[9]> base::cat("dl.move", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t")
Browse[9]> cleanEx()

detaching ‘package:lattice’, ‘package:ggplot2’

Browse[9]> nameEx("dl.trans")
Browse[9]> ### * dl.trans
Browse[9]> 
debug: attr(d, "orig.data") <- d
Browse[10]> flush(stderr()); flush(stdout())
Browse[10]> 
debug: check.for.columns(d, columns.to.check)
Browse[10]> base::assign(".ptime", proc.time(), pos = "CheckExEnv")
Browse[10]> ### Name: dl.trans
Browse[10]> ### Title: Direct label data transform
Browse[10]> ### Aliases: dl.trans
Browse[10]> 
debug: if (!is.list(method)) method <- list(method)
Browse[10]> ### ** Examples
Browse[10]> 
debug: method <- list(method)
Browse[10]> complicated <- list(dl.trans(x=x+10),
+                     gapply.fun(d[-2,]),
+                     rot=c(30,180))
Browse[10]> library(lattice)
Browse[10]> direct.label(dotplot(VADeaths,type="o"),complicated,TRUE)
Called from: apply.method(x$method, cm.data, debug = x$debug, axes2native = x$axes2native)
Browse[11]> 
debug: attr(d, "orig.data") <- d
Browse[12]> 
debug: check.for.columns(d, columns.to.check)
Browse[12]> 
debug: if (!is.list(method)) method <- list(method)
Browse[12]> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv")
Browse[12]> base::cat("dl.trans", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t")
Browse[12]> cleanEx()

detaching ‘package:lattice’

Browse[12]> nameEx("dlcompare")
Browse[12]> ### * dlcompare
Browse[12]> 
debug: isconst <- function() {
    m.var <- names(method)[1]
    !(is.null(m.var) || m.var == "")
}
Browse[12]> flush(stderr()); flush(stdout())
Browse[12]> 
debug: islist <- function() is.list(method[[1]])
Browse[12]> base::assign(".ptime", proc.time(), pos = "CheckExEnv")
Browse[12]> ### Name: dlcompare
Browse[12]> ### Title: Direct label comparison plot
Browse[12]> ### Aliases: dlcompare
Browse[12]> 
debug: isref <- function() (!isconst()) && is.character(method[[1]])
Browse[12]> ### ** Examples
Browse[12]> 
debug: while (length(method)) {
    if (debug) 
        print(method[1])
    while (islist() || isref()) {
        if (islist()) {
            method <- c(method[[1]], method[-1])
        }
        else {
            if (length(method[[1]]) > 1) {
                warning("using first element of character vector")
                method[[1]] <- method[[1]][1]
            }
            method <- c(get(method[[1]]), method[-1])
        }
    }
    if (isconst()) 
        d[[names(method)[1]]] <- method[[1]]
    else {
        old <- d
        group.dfs <- split(d, d$groups)
        group.specific <- lapply(group.dfs, only.unique.vals)
        to.restore <- Reduce(intersect, lapply(group.specific, 
            names))
        d <- method[[1]](d, debug = debug, ...)
        if (length(d) == 0) {
            return(data.frame())
        }
        else {
            check.for.columns(d, columns.to.check)
            if ("groups" %in% names(d)) {
                to.restore <- to.restore[!to.restore %in% names(d)]
                for (N in to.restore) {
                  d[[N]] <- NA
                  group.vec <- paste(unique(d$groups))
                  for (g in group.vec) {
                    old.val <- group.specific[[g]][, N]
                    if (is.factor(old.val)) 
                      old.val <- paste(old.val)
                    d[d$groups == g, N] <- old.val
                  }
                }
            }
        }
        attr(d, "orig.data") <- if (is.null(attr(old, "orig.data"))) 
            old
        else attr(old, "orig.data")
    }
    if (debug) {
        print(d)
    }
    method <- method[-1]
}
Browse[12]> library(lattice)
Browse[12]> oldopt <- lattice.options(panel.error=NULL)
Browse[12]> 
debug: if (debug) print(method[1])
Browse[12]> ## Compare two plots of the same data using lattice and ggplot2.
Browse[12]> deaths.by.sex <- list(male=mdeaths, female=fdeaths)
Browse[12]> deaths.list <- list()
Browse[12]> for(sex in names(deaths.by.sex)){
+   deaths.ts <- deaths.by.sex[[sex]]
+   deaths.list[[sex]] <-
+     data.frame(year=as.numeric(time(deaths.ts)),
+                sex,
+                deaths=as.integer(deaths.ts))
+ }
debug: deaths.ts <- deaths.by.sex[[sex]]
Browse[13]> deaths <- do.call(rbind, deaths.list)
Browse[13]> death.plot.list <-
+   list(lattice=xyplot(deaths~year,deaths,groups=sex,type="l"))
Error in eval(varsRHS[[1]], data, env) : object 'year' not found
Calls: print ... xyplot.formula -> latticeParseFormula -> eval -> eval
Browse[13]> if(require(ggplot2)){
+   death.plot.list$ggplot2 <- 
+     qplot(year,deaths,data=deaths,colour=sex,geom="line")
+ }
Loading required package: ggplot2
debug: death.plot.list$ggplot2 <- qplot(year, deaths, data = deaths, 
    colour = sex, geom = "line")
Browse[14]> 
Error in death.plot.list$ggplot2 <- qplot(year, deaths, data = deaths,  : 
  object 'death.plot.list' not found
Calls: print ... drawGrob -> drawDetails -> drawDetails.dlgrob -> apply.method
Browse[13]> if(names(dev.cur())!="postscript"){##to avoid error on pkg check.
+   ## Use some exotic labeling options with different rotation, font
+   ## face, family, and alpha transparency.
+   exotic <- list("last.points",
+                  rot=c(0,180),
+                  fontsize=c(10,20),
+                  fontface=c("bold","italic"),
+                  fontfamily=c("mono","serif"),
+                  alpha=c(0.25,1))
+   dlcompare(death.plot.list, list(exotic))
+ }
debug: exotic <- list("last.points", rot = c(0, 180), fontsize = c(10, 
    20), fontface = c("bold", "italic"), fontfamily = c("mono", 
    "serif"), alpha = c(0.25, 1))
Browse[14]>   
Browse[14]> lattice.options(oldopt)
Browse[14]> 
debug: dlcompare(death.plot.list, list(exotic))
Browse[14]> ## Compare a legend with direct labels on the same plot.
Browse[14]> library(nlme)

Attaching package: ‘nlme’

The following object is masked from ‘package:directlabels’:

    gapply

Browse[14]> if(require(ggplot2)){
+   ggrat <- qplot(Time,weight,data=BodyWeight,
+                  colour=Rat,geom="line",facets=.~Diet)
+   pfuns <- list("legend","direct labels"="last.qp")
+   dlcompare(list(ggrat),pfuns,rects=FALSE,row.items="posfuns")
+ }
debug: ggrat <- qplot(Time, weight, data = BodyWeight, colour = Rat, 
    geom = "line", facets = . ~ Diet)
Browse[15]> 
debug: pfuns <- list("legend", `direct labels` = "last.qp")
Browse[15]> 
debug: dlcompare(list(ggrat), pfuns, rects = FALSE, row.items = "posfuns")
Browse[15]> 
Called from: apply.method(x$method, cm.data, debug = x$debug, axes2native = x$axes2native)
Browse[15]> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv")
Browse[15]> base::cat("dlcompare", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t")
Browse[15]> cleanEx()

detaching ‘package:nlme’, ‘package:ggplot2’, ‘package:lattice’

Browse[15]> nameEx("gapply.fun")
Browse[15]> ### * gapply.fun
Browse[15]> 
debug: attr(d, "orig.data") <- d
Browse[16]> flush(stderr()); flush(stdout())
Browse[16]> 
debug: check.for.columns(d, columns.to.check)
Browse[16]> base::assign(".ptime", proc.time(), pos = "CheckExEnv")
Browse[16]> ### Name: gapply.fun
Browse[16]> ### Title: Direct label groups independently
Browse[16]> ### Aliases: gapply.fun
Browse[16]> 
debug: if (!is.list(method)) method <- list(method)
Browse[16]> ### ** Examples
Browse[16]> 
debug: method <- list(method)
Browse[16]> complicated <- list(dl.trans(x=x+10),
+                     gapply.fun(d[-2,]),
+                     rot=c(30,180))
Browse[16]> library(lattice)
Browse[16]> direct.label(dotplot(VADeaths,type="o"),complicated,TRUE)
Called from: apply.method(x$method, cm.data, debug = x$debug, axes2native = x$axes2native)
Browse[17]> 
debug: attr(d, "orig.data") <- d
Browse[18]> 
debug: check.for.columns(d, columns.to.check)
Browse[18]> 
debug: if (!is.list(method)) method <- list(method)
Browse[18]> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv")
Browse[18]> base::cat("gapply.fun", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t")
Browse[18]> cleanEx()

detaching ‘package:lattice’

Browse[18]> nameEx("geom_dl")
Browse[18]> ### * geom_dl
Browse[18]> 
debug: isconst <- function() {
    m.var <- names(method)[1]
    !(is.null(m.var) || m.var == "")
}
Browse[18]> flush(stderr()); flush(stdout())
Browse[18]> 
debug: islist <- function() is.list(method[[1]])
Browse[18]> base::assign(".ptime", proc.time(), pos = "CheckExEnv")
Browse[18]> ### Name: geom_dl
Browse[18]> ### Title: geom dl
Browse[18]> ### Aliases: geom_dl
Browse[18]> 
debug: isref <- function() (!isconst()) && is.character(method[[1]])
Browse[18]> ### ** Examples
Browse[18]> 
debug: while (length(method)) {
    if (debug) 
        print(method[1])
    while (islist() || isref()) {
        if (islist()) {
            method <- c(method[[1]], method[-1])
        }
        else {
            if (length(method[[1]]) > 1) {
                warning("using first element of character vector")
                method[[1]] <- method[[1]][1]
            }
            method <- c(get(method[[1]]), method[-1])
        }
    }
    if (isconst()) 
        d[[names(method)[1]]] <- method[[1]]
    else {
        old <- d
        group.dfs <- split(d, d$groups)
        group.specific <- lapply(group.dfs, only.unique.vals)
        to.restore <- Reduce(intersect, lapply(group.specific, 
            names))
        d <- method[[1]](d, debug = debug, ...)
        if (length(d) == 0) {
            return(data.frame())
        }
        else {
            check.for.columns(d, columns.to.check)
            if ("groups" %in% names(d)) {
                to.restore <- to.restore[!to.restore %in% names(d)]
                for (N in to.restore) {
                  d[[N]] <- NA
                  group.vec <- paste(unique(d$groups))
                  for (g in group.vec) {
                    old.val <- group.specific[[g]][, N]
                    if (is.factor(old.val)) 
                      old.val <- paste(old.val)
                    d[d$groups == g, N] <- old.val
                  }
                }
            }
        }
        attr(d, "orig.data") <- if (is.null(attr(old, "orig.data"))) 
            old
        else attr(old, "orig.data")
    }
    if (debug) {
        print(d)
    }
    method <- method[-1]
}
Browse[18]> if(require(ggplot2)){
+   vad <- as.data.frame.table(VADeaths)
+   names(vad) <- c("age","demographic","deaths")
+   ## color + legend
+   leg <- ggplot(vad,aes(deaths,age,colour=demographic))+
+     geom_line(aes(group=demographic))+
+     xlim(8,80)
+   print(direct.label(leg,list("last.points",rot=30)))
+   ## this is what direct.label is doing internally:
+   labeled <- leg+
+     geom_dl(aes(label=demographic), method=list("last.points",rot=30))+
+     scale_colour_discrete(guide="none")
+   print(labeled)
+   ## no color, just direct labels!
+   p <- ggplot(vad,aes(deaths,age))+
+     geom_line(aes(group=demographic))+
+     geom_dl(aes(label=demographic),method="top.qp")
+   print(p)
+   ## add color:
+   p+aes(colour=demographic)+
+     scale_colour_discrete(guide="none")
+   ## add linetype:
+   p+aes(linetype=demographic)+
+     scale_linetype(guide="none")
+   ## no color, just direct labels
+   library(nlme)
+   bwbase <- ggplot(BodyWeight,aes(Time,weight,label=Rat))+
+     geom_line(aes(group=Rat))+
+     facet_grid(.~Diet)
+   bw <- bwbase+geom_dl(method="last.qp")
+   print(bw)
+   ## add some more direct labels
+   bw2 <- bw+geom_dl(method="first.qp")
+   print(bw2)
+   ## add color
+   colored <- bw2+aes(colour=Rat)+
+     scale_colour_discrete(guide="none")
+   print(colored)
+   ## or just use direct.label if you use color:
+   direct.label(bwbase+aes(colour=Rat),dl.combine("first.qp","last.qp"))
+ 
+   ## iris data example
+   giris <- ggplot(iris,aes(Petal.Length,Sepal.Length))+
+     geom_point(aes(shape=Species))
+   giris.labeled <- giris+
+     geom_dl(aes(label=Species),method="smart.grid")+
+     scale_shape_manual(values=c(setosa=1,virginica=6,versicolor=3),
+                        guide="none")
+   ##png("~/R/directlabels/www/scatter-bw-ggplot2.png",h=503,w=503)
+   print(giris.labeled)
+   ##dev.off()
+ }
Loading required package: ggplot2
debug: vad <- as.data.frame.table(VADeaths)
Browse[19]> 
debug: names(vad) <- c("age", "demographic", "deaths")
Browse[19]> 
debug: leg <- ggplot(vad, aes(deaths, age, colour = demographic)) + 
    geom_line(aes(group = demographic)) + xlim(8, 80)
Browse[19]> 
debug: print(direct.label(leg, list("last.points", rot = 30)))
Browse[19]> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv")
Browse[19]> base::cat("geom_dl", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t")
Browse[19]> cleanEx()

detaching ‘package:ggplot2’

Browse[19]> nameEx("iris.l1.cluster")
Browse[19]> ### * iris.l1.cluster
Browse[19]> 
Called from: apply.method(x$method, cm.data, debug = x$debug, axes2native = x$axes2native)
Browse[19]> flush(stderr()); flush(stdout())
Browse[19]> 
debug: attr(d, "orig.data") <- d
Browse[20]> base::assign(".ptime", proc.time(), pos = "CheckExEnv")
Browse[20]> ### Name: iris.l1.cluster
Browse[20]> ### Title: Clustering of the iris data with the l1 clusterpath
Browse[20]> ### Aliases: iris.l1.cluster
Browse[20]> ### Keywords: datasets
Browse[20]> 
debug: check.for.columns(d, columns.to.check)
Browse[20]> ### ** Examples
Browse[20]> 
debug: if (!is.list(method)) method <- list(method)
Browse[20]> data(iris.l1.cluster,package="directlabels")
Browse[20]> iris.l1.cluster$y <- iris.l1.cluster$alpha
Browse[20]> if(require(ggplot2)){
+   p <- ggplot(iris.l1.cluster,aes(lambda,y,group=row,colour=Species))+
+     geom_line(alpha=1/4)+
+     facet_grid(col~.)
+   p2 <- p+xlim(-0.0025,max(iris.l1.cluster$lambda))
+   print(direct.label(p2,list(first.points,get.means)))
+ }
Loading required package: ggplot2
debug: p <- ggplot(iris.l1.cluster, aes(lambda, y, group = row, colour = Species)) + 
    geom_line(alpha = 1/4) + facet_grid(col ~ .)
Browse[21]> 
debug: p2 <- p + xlim(-0.0025, max(iris.l1.cluster$lambda))
Browse[21]> 
debug: print(direct.label(p2, list(first.points, get.means)))
Browse[21]> 
Called from: apply.method(x$method, cm.data, debug = x$debug, axes2native = x$axes2native)
Browse[21]> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv")
Browse[21]> base::cat("iris.l1.cluster", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t")
Browse[21]> cleanEx()

detaching ‘package:ggplot2’

Browse[21]> nameEx("normal.l2.cluster")
Browse[21]> ### * normal.l2.cluster
Browse[21]> 
debug: attr(d, "orig.data") <- d
Browse[22]> flush(stderr()); flush(stdout())
Browse[22]> 
debug: check.for.columns(d, columns.to.check)
Browse[22]> base::assign(".ptime", proc.time(), pos = "CheckExEnv")
Browse[22]> ### Name: normal.l2.cluster
Browse[22]> ### Title: Clustering of some normal data in 2d with the l2 clusterpath
Browse[22]> ### Aliases: normal.l2.cluster
Browse[22]> ### Keywords: datasets
Browse[22]> 
debug: if (!is.list(method)) method <- list(method)
Browse[22]> ### ** Examples
Browse[22]> 
debug: isconst <- function() {
    m.var <- names(method)[1]
    !(is.null(m.var) || m.var == "")
}
Browse[22]> data(normal.l2.cluster)
Browse[22]> if(require(ggplot2)){
+   p <- ggplot(normal.l2.cluster$path,aes(x,y))+
+     geom_path(aes(group=row),colour="grey")+
+     geom_point(aes(size=lambda),colour="grey")+
+     geom_point(aes(colour=class),data=normal.l2.cluster$pts)+
+     coord_equal()
+   print(direct.label(p))
+ }
Loading required package: ggplot2
debug: p <- ggplot(normal.l2.cluster$path, aes(x, y)) + geom_path(aes(group = row), 
    colour = "grey") + geom_point(aes(size = lambda), colour = "grey") + 
    geom_point(aes(colour = class), data = normal.l2.cluster$pts) + 
    coord_equal()
Browse[23]> 
debug: print(direct.label(p))
Browse[23]> 
Called from: apply.method(x$method, cm.data, debug = x$debug, axes2native = x$axes2native)
Browse[23]> 
debug: attr(d, "orig.data") <- d
Browse[24]> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv")
Browse[24]> base::cat("normal.l2.cluster", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t")
Browse[24]> cleanEx()

detaching ‘package:ggplot2’

Browse[24]> nameEx("panel.superpose.dl")
Browse[24]> ### * panel.superpose.dl
Browse[24]> 
debug: check.for.columns(d, columns.to.check)
Browse[24]> flush(stderr()); flush(stdout())
Browse[24]> 
debug: if (!is.list(method)) method <- list(method)
Browse[24]> base::assign(".ptime", proc.time(), pos = "CheckExEnv")
Browse[24]> ### Name: panel.superpose.dl
Browse[24]> ### Title: panel superpose dl
Browse[24]> ### Aliases: panel.superpose.dl
Browse[24]> 
debug: method <- list(method)
Browse[24]> ### ** Examples
Browse[24]> 
debug: isconst <- function() {
    m.var <- names(method)[1]
    !(is.null(m.var) || m.var == "")
}
Browse[24]> loci <- data.frame(ppp=c(rbeta(800,10,10),rbeta(100,0.15,1),rbeta(100,1,0.15)),
+                    type=factor(c(rep("NEU",800),rep("POS",100),rep("BAL",100))))
Browse[24]> ## 3 equivalent ways to make the same plot:
Browse[24]> library(lattice)
Browse[24]> print(direct.label( ## most user-friendly
+                    densityplot(~ppp,loci,groups=type,n=500)
+                    ))
Called from: apply.method(translator, d, ...)
Browse[25]> print(direct.label( ## exactly the same as above but with specific panel fns
+                    densityplot(~ppp,loci,groups=type,n=500,
+                                panel=lattice::panel.superpose,
+                                panel.groups="panel.densityplot")
+                    ))
Error in eval(substitute(groups), data, environment(formula)) : 
  object 'loci' not found
Calls: print ... direct.label -> densityplot -> densityplot.formula -> eval
Browse[25]> ## using panel.superpose.dl as the panel function automatically adds
Browse[25]> ## direct labels
Browse[25]> print(densityplot(~ppp,loci,groups=type,n=500,
+                   panel=panel.superpose.dl,panel.groups="panel.densityplot"))
Error in eval(substitute(groups), data, environment(formula)) : 
  object 'loci' not found
Calls: print ... print -> densityplot -> densityplot.formula -> eval
Browse[25]> 
debug: attr(d, "orig.data") <- d
Browse[26]> ## Exploring custom panel and panel.groups functions
Browse[26]> library(nlme)

Attaching package: ‘nlme’

The following object is masked from ‘package:directlabels’:

    gapply

Browse[26]> ## Say we want to use a simple linear model to explain rat body weight:
Browse[26]> fit <- lm(weight~Time+Diet+Rat,BodyWeight)
Browse[26]> bw <- BodyWeight
Browse[26]> bw$.fitted <- predict(fit,BodyWeight)
Warning in predict.lm(fit, BodyWeight) :
  prediction from a rank-deficient fit may be misleading
Browse[26]> ## lots of examples to come, all with these arguments:
Browse[26]> ratxy <- function(...){
+   xyplot(weight~Time|Diet,bw,groups=Rat,type="l",layout=c(3,1),...)
+ }
Browse[26]> ## No custom panel functions:
Browse[26]> ##regular <- ratxy(par.settings=simpleTheme(col=c("red","black")))
Browse[26]> regular <- ratxy()
Browse[26]> print(regular) ## normal lattice plot
Browse[26]> print(direct.label(regular)) ## with direct labels
Called from: apply.method(x$method, cm.data, debug = x$debug, axes2native = x$axes2native)
Browse[27]> 
debug: attr(d, "orig.data") <- d
Browse[28]> ## The direct label panel function panel.superpose.dl can be used to
Browse[28]> ## display direct labels as well:
Browse[28]> print(ratxy(panel=panel.superpose.dl,panel.groups="panel.xyplot"))
Error in ratxy(panel = panel.superpose.dl, panel.groups = "panel.xyplot") : 
  could not find function "ratxy"
Calls: print ... drawDetails -> drawDetails.dlgrob -> apply.method -> print
Browse[28]> print(ratxy(panel=function(...)
+             panel.superpose.dl(panel.groups="panel.xyplot",...)))
Error in ratxy(panel = function(...) panel.superpose.dl(panel.groups = "panel.xyplot",  : 
  could not find function "ratxy"
Calls: print ... drawDetails -> drawDetails.dlgrob -> apply.method -> print
Browse[28]> 
debug: check.for.columns(d, columns.to.check)
Browse[28]> ## Not very user-friendly, since default label placement is
Browse[28]> ## impossible, but these should work:
Browse[28]> print(ratxy(panel=panel.superpose.dl,panel.groups=panel.xyplot,
+             method=first.points))
Error in ratxy(panel = panel.superpose.dl, panel.groups = panel.xyplot,  : 
  could not find function "ratxy"
Calls: print ... drawDetails -> drawDetails.dlgrob -> apply.method -> print
Browse[28]> print(ratxy(panel=function(...)
+             panel.superpose.dl(panel.groups=panel.xyplot,...),
+             method=first.points))
Error in ratxy(panel = function(...) panel.superpose.dl(panel.groups = panel.xyplot,  : 
  could not find function "ratxy"
Calls: print ... drawDetails -> drawDetails.dlgrob -> apply.method -> print
Browse[28]> 
debug: if (!is.list(method)) method <- list(method)
Browse[28]> ## Custom panel.groups functions:
Browse[28]> ## This panel.groups function will display the model fits:
Browse[28]> panel.model <- function(x,subscripts,col.line,...){
+   panel.xyplot(x=x,subscripts=subscripts,col.line=col.line,...)
+   llines(x,bw[subscripts,".fitted"],col=col.line,lty=2)
+ }
Browse[28]> pg <- ratxy(panel=lattice::panel.superpose,panel.groups=panel.model)
Error in ratxy(panel = lattice::panel.superpose, panel.groups = panel.model) : 
  could not find function "ratxy"
Calls: print ... drawGrob -> drawDetails -> drawDetails.dlgrob -> apply.method
Browse[28]> print(pg)
Error in print(pg) : object 'pg' not found
Calls: print ... drawDetails -> drawDetails.dlgrob -> apply.method -> print
Browse[28]> ## If you use panel.superpose.dl with a custom panel.groups function,
Browse[28]> ## you need to manually specify the Positioning Method, since the
Browse[28]> ## name of panel.groups is used to infer a default:
Browse[28]> print(direct.label(pg,method="first.qp"))
Error in direct.label(pg, method = "first.qp") : object 'pg' not found
Calls: print ... drawDetails.dlgrob -> apply.method -> print -> direct.label
Browse[28]> print(ratxy(panel=panel.superpose.dl,panel.groups="panel.model",
+             method="first.qp"))
Error in ratxy(panel = panel.superpose.dl, panel.groups = "panel.model",  : 
  could not find function "ratxy"
Calls: print ... drawDetails -> drawDetails.dlgrob -> apply.method -> print
Browse[28]> 
debug: method <- list(method)
Browse[28]> ## Custom panel function that draws a box around values:
Browse[28]> panel.line1 <- function(ps=lattice::panel.superpose){
+   function(y,...){
+     panel.abline(h=range(y))
+     ps(y=y,...)
+   }
+ }
Browse[28]> custom <- ratxy(panel=panel.line1())
Error in ratxy(panel = panel.line1()) : could not find function "ratxy"
Calls: print ... drawGrob -> drawDetails -> drawDetails.dlgrob -> apply.method
Browse[28]> print(custom)
Error in print(custom) : object 'custom' not found
Calls: print ... drawDetails -> drawDetails.dlgrob -> apply.method -> print
Browse[28]> print(direct.label(custom))
Error in direct.label(custom) : object 'custom' not found
Calls: print ... drawDetails.dlgrob -> apply.method -> print -> direct.label
Browse[28]> ## Alternate method, producing the same results, but using
Browse[28]> ## panel.superpose.dl in the panel function. This is useful for direct
Browse[28]> ## label plots where you use several datasets.
Browse[28]> print(ratxy(panel=panel.line1(panel.superpose.dl),panel.groups="panel.xyplot"))
Error in ratxy(panel = panel.line1(panel.superpose.dl), panel.groups = "panel.xyplot") : 
  could not find function "ratxy"
Calls: print ... drawDetails -> drawDetails.dlgrob -> apply.method -> print
Browse[28]> 
debug: isconst <- function() {
    m.var <- names(method)[1]
    !(is.null(m.var) || m.var == "")
}
Browse[28]> ## Lattice plot with custom panel and panel.groups functions:
Browse[28]> both <- ratxy(panel=panel.line1(),panel.groups="panel.model")
Error in ratxy(panel = panel.line1(), panel.groups = "panel.model") : 
  could not find function "ratxy"
Calls: print ... drawGrob -> drawDetails -> drawDetails.dlgrob -> apply.method
Browse[28]> print(both)
Error in print(both) : object 'both' not found
Calls: print ... drawDetails -> drawDetails.dlgrob -> apply.method -> print
Browse[28]> print(direct.label(both,method="first.qp"))
Error in direct.label(both, method = "first.qp") : 
  object 'both' not found
Calls: print ... drawDetails.dlgrob -> apply.method -> print -> direct.label
Browse[28]> print(ratxy(panel=panel.line1(panel.superpose.dl),
+             panel.groups=panel.model,method="first.qp"))
Error in ratxy(panel = panel.line1(panel.superpose.dl), panel.groups = panel.model,  : 
  could not find function "ratxy"
Calls: print ... drawDetails -> drawDetails.dlgrob -> apply.method -> print
Browse[28]> 
debug: islist <- function() is.list(method[[1]])
Browse[28]> 
debug: isref <- function() (!isconst()) && is.character(method[[1]])
Browse[28]> 
debug: while (length(method)) {
    if (debug) 
        print(method[1])
    while (islist() || isref()) {
        if (islist()) {
            method <- c(method[[1]], method[-1])
        }
        else {
            if (length(method[[1]]) > 1) {
                warning("using first element of character vector")
                method[[1]] <- method[[1]][1]
            }
            method <- c(get(method[[1]]), method[-1])
        }
    }
    if (isconst()) 
        d[[names(method)[1]]] <- method[[1]]
    else {
        old <- d
        group.dfs <- split(d, d$groups)
        group.specific <- lapply(group.dfs, only.unique.vals)
        to.restore <- Reduce(intersect, lapply(group.specific, 
            names))
        d <- method[[1]](d, debug = debug, ...)
        if (length(d) == 0) {
            return(data.frame())
        }
        else {
            check.for.columns(d, columns.to.check)
            if ("groups" %in% names(d)) {
                to.restore <- to.restore[!to.restore %in% names(d)]
                for (N in to.restore) {
                  d[[N]] <- NA
                  group.vec <- paste(unique(d$groups))
                  for (g in group.vec) {
                    old.val <- group.specific[[g]][, N]
                    if (is.factor(old.val)) 
                      old.val <- paste(old.val)
                    d[d$groups == g, N] <- old.val
                  }
                }
            }
        }
        attr(d, "orig.data") <- if (is.null(attr(old, "orig.data"))) 
            old
        else attr(old, "orig.data")
    }
    if (debug) {
        print(d)
    }
    method <- method[-1]
}
Browse[28]> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv")
Browse[28]> base::cat("panel.superpose.dl", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t")
Browse[28]> cleanEx()

detaching ‘package:nlme’, ‘package:lattice’

Browse[28]> nameEx("positioning.functions")
Browse[28]> ### * positioning.functions
Browse[28]> 
debug: if (debug) print(method[1])
Browse[28]> flush(stderr()); flush(stdout())
Browse[28]> 
debug: while (islist() || isref()) {
    if (islist()) {
        method <- c(method[[1]], method[-1])
    }
    else {
        if (length(method[[1]]) > 1) {
            warning("using first element of character vector")
            method[[1]] <- method[[1]][1]
        }
        method <- c(get(method[[1]]), method[-1])
    }
}
Browse[28]> base::assign(".ptime", proc.time(), pos = "CheckExEnv")
Browse[28]> ### Name: positioning.functions
Browse[28]> ### Title: Built-in Positioning Methods for direct label placement
Browse[28]> ### Aliases: positioning.functions positioning.methods
Browse[28]> 
debug: if (islist()) {
    method <- c(method[[1]], method[-1])
} else {
    if (length(method[[1]]) > 1) {
        warning("using first element of character vector")
        method[[1]] <- method[[1]][1]
    }
    method <- c(get(method[[1]]), method[-1])
}
Browse[28]> ### ** Examples
Browse[28]> 
debug: if (length(method[[1]]) > 1) {
    warning("using first element of character vector")
    method[[1]] <- method[[1]][1]
}
Browse[28]> ## Not run: 
Browse[28]> ##D ### contourplot Positioning Methods
Browse[28]> ##D for(p in list({
Browse[28]> ##D ## Example from help(contourplot)
Browse[28]> ##D require(stats)
Browse[28]> ##D require(lattice)
Browse[28]> ##D attach(environmental)
Browse[28]> ##D ozo.m <- loess((ozone^(1/3)) ~ wind * temperature * radiation,
Browse[28]> ##D                parametric = c("radiation", "wind"), span = 1, degree = 2)
Browse[28]> ##D w.marginal <- seq(min(wind), max(wind), length.out = 50)
Browse[28]> ##D t.marginal <- seq(min(temperature), max(temperature), length.out = 50)
Browse[28]> ##D r.marginal <- seq(min(radiation), max(radiation), length.out = 4)
Browse[28]> ##D wtr.marginal <- list(wind = w.marginal, temperature = t.marginal,
Browse[28]> ##D                      radiation = r.marginal)
Browse[28]> ##D grid <- expand.grid(wtr.marginal)
Browse[28]> ##D grid[, "fit"] <- c(predict(ozo.m, grid))
Browse[28]> ##D detach(environmental)
Browse[28]> ##D library(ggplot2)
Browse[28]> ##D p <- ggplot(grid,aes(wind,temperature,z=fit))+
Browse[28]> ##D   stat_contour(aes(colour=..level..))+
Browse[28]> ##D   facet_wrap(~radiation)
Browse[28]> ##D 
Browse[28]> ##D },
Browse[28]> ##D {
Browse[28]> ##D ## example from help(stat_contour)
Browse[28]> ##D library(reshape2)
Browse[28]> ##D volcano3d <- melt(volcano)
Browse[28]> ##D names(volcano3d) <- c("x", "y", "z")
Browse[28]> ##D library(ggplot2)
Browse[28]> ##D p <- ggplot(volcano3d, aes(x, y, z = z))+
Browse[28]> ##D   stat_contour(aes(colour = ..level..))
Browse[28]> ##D })){
Browse[28]> ##D   print(direct.label(p,"bottom.pieces"))
Browse[28]> ##D   print(direct.label(p,"top.pieces"))
Browse[28]> ##D }
Browse[28]> ##D 
Browse[28]> ##D ### densityplot Positioning Methods
Browse[28]> ##D for(p in list({
Browse[28]> ##D data(Chem97,package="mlmRev")
Browse[28]> ##D library(lattice)
Browse[28]> ##D p <- densityplot(~gcsescore|gender,Chem97,
Browse[28]> ##D             groups=factor(score),layout=c(1,2),
Browse[28]> ##D             n=500,plot.points=FALSE)
Browse[28]> ##D },
Browse[28]> ##D {
Browse[28]> ##D library(reshape2)
Browse[28]> ##D iris2 <- melt(iris,id="Species")
Browse[28]> ##D library(lattice)
Browse[28]> ##D p <- densityplot(~value|variable,iris2,groups=Species,scales="free")
Browse[28]> ##D },
Browse[28]> ##D {
Browse[28]> ##D loci <- data.frame(ppp=c(rbeta(800,10,10),rbeta(100,0.15,1),rbeta(100,1,0.15)),
Browse[28]> ##D                    type=factor(c(rep("NEU",800),rep("POS",100),rep("BAL",100))))
Browse[28]> ##D library(ggplot2)
Browse[28]> ##D p <- qplot(ppp,data=loci,colour=type,geom="density")
Browse[28]> ##D })){
Browse[28]> ##D   print(direct.label(p,"bottom.points"))
Browse[28]> ##D   print(direct.label(p,"top.bumptwice"))
Browse[28]> ##D   print(direct.label(p,"top.bumpup"))
Browse[28]> ##D   print(direct.label(p,"top.points"))
Browse[28]> ##D }
Browse[28]> ##D 
Browse[28]> ##D ### dotplot Positioning Methods
Browse[28]> ##D for(p in list({
Browse[28]> ##D library(lattice)
Browse[28]> ##D p <- dotplot(VADeaths,xlim=c(8,85),type="o")
Browse[28]> ##D },
Browse[28]> ##D {
Browse[28]> ##D vad <- as.data.frame.table(VADeaths)
Browse[28]> ##D names(vad) <- c("age","demographic","deaths")
Browse[28]> ##D library(ggplot2)
Browse[28]> ##D p <- qplot(deaths,age,data=vad,group=demographic,geom="line",colour=demographic)+
Browse[28]> ##D   xlim(8,80)
Browse[28]> ##D })){
Browse[28]> ##D   print(direct.label(p,"angled.endpoints"))
Browse[28]> ##D   print(direct.label(p,"top.qp"))
Browse[28]> ##D }
Browse[28]> ##D 
Browse[28]> ##D ### lineplot Positioning Methods
Browse[28]> ##D for(p in list({
Browse[28]> ##D data(BodyWeight,package="nlme")
Browse[28]> ##D library(lattice)
Browse[28]> ##D p <- xyplot(weight~Time|Diet,BodyWeight,groups=Rat,type='l',
Browse[28]> ##D        layout=c(3,1),xlim=c(-10,75))
Browse[28]> ##D },
Browse[28]> ##D {
Browse[28]> ##D data(Chem97,package="mlmRev")
Browse[28]> ##D library(lattice)
Browse[28]> ##D p <- qqmath(~gcsescore|gender,Chem97,groups=factor(score),
Browse[28]> ##D        type=c('l','g'),f.value=ppoints(100))
Browse[28]> ##D },
Browse[28]> ##D {
Browse[28]> ##D data(Chem97,package="mlmRev")
Browse[28]> ##D library(lattice)
Browse[28]> ##D p <- qqmath(~gcsescore,Chem97,groups=gender,
Browse[28]> ##D        type=c("l","g"),f.value=ppoints(100))
Browse[28]> ##D },
Browse[28]> ##D {
Browse[28]> ##D data(Prostate,package="lasso2")
Browse[28]> ##D Prostate$train <- c(
Browse[28]> ##D   1, 1, 1, 1, 1, 1, 0, 1, 0, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 
Browse[28]> ##D   1, 0, 1, 1, 0, 0, 1, 0, 1, 1, 1, 0, 1, 0, 1, 0, 1, 1, 1, 1, 1, 
Browse[28]> ##D   0, 1, 0, 1, 1, 1, 0, 0, 0, 1, 1, 0, 0, 0, 1, 0, 1, 1, 1, 1, 0, 
Browse[28]> ##D   1, 0, 0, 0, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1, 1, 1, 0, 1, 1, 1, 
Browse[28]> ##D   0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1, 0)
Browse[28]> ##D pros <- subset(Prostate,select=-train,train==1)
Browse[28]> ##D ycol <- which(names(pros)=="lpsa")
Browse[28]> ##D x <- as.matrix(pros[-ycol])
Browse[28]> ##D y <- pros[[ycol]]
Browse[28]> ##D library(lars)
Browse[28]> ##D fit <- lars(x,y,type="lasso")
Browse[28]> ##D beta <- scale(coef(fit),FALSE,1/fit$normx)
Browse[28]> ##D arclength <- rowSums(abs(beta))
Browse[28]> ##D library(reshape2)
Browse[28]> ##D path <- data.frame(melt(beta),arclength)
Browse[28]> ##D names(path)[1:3] <- c("step","variable","standardized.coef")
Browse[28]> ##D library(ggplot2)
Browse[28]> ##D p <- ggplot(path,aes(arclength,standardized.coef,colour=variable))+
Browse[28]> ##D   geom_line(aes(group=variable))+
Browse[28]> ##D   ggtitle("LASSO path for Prostate cancer data calculated using the LARS")+
Browse[28]> ##D   xlim(0,20)
Browse[28]> ##D },
Browse[28]> ##D {
Browse[28]> ##D data(projectionSeconds, package="directlabels")
Browse[28]> ##D p <- ggplot(projectionSeconds, aes(vector.length/1e6))+
Browse[28]> ##D   geom_ribbon(aes(ymin=min, ymax=max,
Browse[28]> ##D                   fill=method, group=method), alpha=1/2)+
Browse[28]> ##D   geom_line(aes(y=mean, group=method, colour=method))+
Browse[28]> ##D   ggtitle("Projection Time against Vector Length (Sparsity = 10##D 
Browse[28]> ##D   guides(fill="none")+
Browse[28]> ##D   ylab("Runtime (s)")
Browse[28]> ##D },
Browse[28]> ##D {
Browse[28]> ##D ## complicated ridge regression lineplot ex. fig 3.8 from Elements of
Browse[28]> ##D ## Statistical Learning, Hastie et al.
Browse[28]> ##D myridge <- function(f,data,lambda=c(exp(-seq(-15,15,l=200)),0)){
Browse[28]> ##D   require(MASS)
Browse[28]> ##D   require(reshape2)
Browse[28]> ##D   fit <- lm.ridge(f,data,lambda=lambda)
Browse[28]> ##D   X <- data[-which(names(data)==as.character(f[[2]]))]
Browse[28]> ##D   Xs <- svd(scale(X)) ## my d's should come from the scaled matrix
Browse[28]> ##D   dsq <- Xs$d^2
Browse[28]> ##D   ## make the x axis degrees of freedom
Browse[28]> ##D   df <- sapply(lambda,function(l)sum(dsq/(dsq+l)))
Browse[28]> ##D   D <- data.frame(t(fit$coef),lambda,df) # scaled coefs
Browse[28]> ##D   molt <- melt(D,id=c("lambda","df"))
Browse[28]> ##D   ## add in the points for df=0
Browse[28]> ##D   limpts <- transform(subset(molt,lambda==0),lambda=Inf,df=0,value=0)
Browse[28]> ##D   rbind(limpts,molt)
Browse[28]> ##D }
Browse[28]> ##D data(Prostate,package="lasso2")
Browse[28]> ##D Prostate$train <- c(
Browse[28]> ##D   1, 1, 1, 1, 1, 1, 0, 1, 0, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 
Browse[28]> ##D   1, 0, 1, 1, 0, 0, 1, 0, 1, 1, 1, 0, 1, 0, 1, 0, 1, 1, 1, 1, 1, 
Browse[28]> ##D   0, 1, 0, 1, 1, 1, 0, 0, 0, 1, 1, 0, 0, 0, 1, 0, 1, 1, 1, 1, 0, 
Browse[28]> ##D   1, 0, 0, 0, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1, 1, 1, 0, 1, 1, 1, 
Browse[28]> ##D   0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1, 0)
Browse[28]> ##D pros <- subset(Prostate,train==1,select=-train)
Browse[28]> ##D m <- myridge(lpsa~.,pros)
Browse[28]> ##D library(lattice)
Browse[28]> ##D p <- xyplot(value~df,m,groups=variable,type="o",pch="+",
Browse[28]> ##D        panel=function(...){
Browse[28]> ##D          panel.xyplot(...)
Browse[28]> ##D          panel.abline(h=0)
Browse[28]> ##D          panel.abline(v=5,col="grey")
Browse[28]> ##D        },
Browse[28]> ##D        xlim=c(-1,9),
Browse[28]> ##D        main="Ridge regression shrinks least squares coefficients",
Browse[28]> ##D        ylab="scaled coefficients",
Browse[28]> ##D        sub="grey line shows coefficients chosen by cross-validation",
Browse[28]> ##D        xlab=expression(df(lambda)))
Browse[28]> ##D },
Browse[28]> ##D {
Browse[28]> ##D library(ggplot2)
Browse[28]> ##D tx <- time(mdeaths)
Browse[28]> ##D Time <- ISOdate(floor(tx),round(tx##D 
Browse[28]> ##D uk.lung <- rbind(data.frame(Time,sex="male",deaths=as.integer(mdeaths)),
Browse[28]> ##D                  data.frame(Time,sex="female",deaths=as.integer(fdeaths)))
Browse[28]> ##D p <- qplot(Time,deaths,data=uk.lung,colour=sex,geom="line")+
Browse[28]> ##D   xlim(ISOdate(1973,9,1),ISOdate(1980,4,1))
Browse[28]> ##D })){
Browse[28]> ##D   print(direct.label(p,"angled.boxes"))
Browse[28]> ##D   print(direct.label(p,"bottom.polygons"))
Browse[28]> ##D   print(direct.label(p,"first.bumpup"))
Browse[28]> ##D   print(direct.label(p,"first.points"))
Browse[28]> ##D   print(direct.label(p,"first.polygons"))
Browse[28]> ##D   print(direct.label(p,"first.qp"))
Browse[28]> ##D   print(direct.label(p,"lasso.labels"))
Browse[28]> ##D   print(direct.label(p,"last.bumpup"))
Browse[28]> ##D   print(direct.label(p,"last.points"))
Browse[28]> ##D   print(direct.label(p,"last.polygons"))
Browse[28]> ##D   print(direct.label(p,"last.qp"))
Browse[28]> ##D   print(direct.label(p,"left.points"))
Browse[28]> ##D   print(direct.label(p,"left.polygons"))
Browse[28]> ##D   print(direct.label(p,"lines2"))
Browse[28]> ##D   print(direct.label(p,"maxvar.points"))
Browse[28]> ##D   print(direct.label(p,"maxvar.qp"))
Browse[28]> ##D   print(direct.label(p,"right.points"))
Browse[28]> ##D   print(direct.label(p,"right.polygons"))
Browse[28]> ##D   print(direct.label(p,"top.polygons"))
Browse[28]> ##D }
Browse[28]> ##D 
Browse[28]> ##D ### scatterplot Positioning Methods
Browse[28]> ##D for(p in list({
Browse[28]> ##D data(mpg,package="ggplot2")
Browse[28]> ##D m <- lm(cty~displ,data=mpg)
Browse[28]> ##D mpgf <- fortify(m,mpg)
Browse[28]> ##D library(lattice)
Browse[28]> ##D library(latticeExtra)
Browse[28]> ##D p <- xyplot(cty~hwy|manufacturer,mpgf,groups=class,aspect="iso",
Browse[28]> ##D        main="City and highway fuel efficiency by car class and manufacturer")+
Browse[28]> ##D   layer_(panel.abline(0,1,col="grey90"))
Browse[28]> ##D },
Browse[28]> ##D {
Browse[28]> ##D data(mpg,package="ggplot2")
Browse[28]> ##D m <- lm(cty~displ,data=mpg)
Browse[28]> ##D mpgf <- fortify(m,mpg)
Browse[28]> ##D library(lattice)
Browse[28]> ##D p <- xyplot(jitter(.resid)~jitter(.fitted),mpgf,groups=factor(cyl))
Browse[28]> ##D },
Browse[28]> ##D {
Browse[28]> ##D library(lattice)
Browse[28]> ##D p <- xyplot(jitter(Sepal.Length)~jitter(Petal.Length),iris,groups=Species)
Browse[28]> ##D },
Browse[28]> ##D {
Browse[28]> ##D data(mpg,package="ggplot2")
Browse[28]> ##D library(lattice)
Browse[28]> ##D p <- xyplot(jitter(cty)~jitter(hwy),mpg,groups=class,
Browse[28]> ##D        main="Fuel efficiency depends on car size")
Browse[28]> ##D },
Browse[28]> ##D {
Browse[28]> ##D library(ggplot2)
Browse[28]> ##D data(mpg,package="ggplot2")
Browse[28]> ##D p <- qplot(jitter(hwy),jitter(cty),data=mpg,colour=class,
Browse[28]> ##D       main="Fuel efficiency depends on car size")
Browse[28]> ##D },
Browse[28]> ##D {
Browse[28]> ##D data(normal.l2.cluster,package="directlabels")
Browse[28]> ##D library(ggplot2)
Browse[28]> ##D p <- ggplot(normal.l2.cluster$path,aes(x,y))+
Browse[28]> ##D   geom_path(aes(group=row),colour="grey")+
Browse[28]> ##D   geom_point(aes(size=lambda),colour="grey")+
Browse[28]> ##D   geom_point(aes(colour=class),data=normal.l2.cluster$pts,pch=21,fill="white")+
Browse[28]> ##D   coord_equal()
Browse[28]> ##D })){
Browse[28]> ##D   print(direct.label(p,"ahull.grid"))
Browse[28]> ##D   print(direct.label(p,"chull.grid"))
Browse[28]> ##D   print(direct.label(p,"extreme.grid"))
Browse[28]> ##D   print(direct.label(p,"smart.grid"))
Browse[28]> ##D }
Browse[28]> ##D 
Browse[28]> ## End(Not run)
Browse[28]> 
debug: method <- c(get(method[[1]]), method[-1])
Browse[28]> 
debug: (while) islist() || isref()
Browse[28]> 
debug: if (islist()) {
    method <- c(method[[1]], method[-1])
} else {
    if (length(method[[1]]) > 1) {
        warning("using first element of character vector")
        method[[1]] <- method[[1]][1]
    }
    method <- c(get(method[[1]]), method[-1])
}
Browse[28]> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv")
Browse[28]> base::cat("positioning.functions", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t")
Browse[28]> cleanEx()
Browse[28]> nameEx("qp.labels")
Browse[28]> ### * qp.labels
Browse[28]> 
debug: if (length(method[[1]]) > 1) {
    warning("using first element of character vector")
    method[[1]] <- method[[1]][1]
}
Browse[28]> flush(stderr()); flush(stdout())
Browse[28]> 
debug: method <- c(get(method[[1]]), method[-1])
Browse[28]> base::assign(".ptime", proc.time(), pos = "CheckExEnv")
Browse[28]> ### Name: qp.labels
Browse[28]> ### Title: Make a Positioning Method for non-overlapping lineplot labels
Browse[28]> ### Aliases: qp.labels
Browse[28]> 
debug: (while) islist() || isref()
Browse[28]> ### ** Examples
Browse[28]> 
debug: if (isconst()) d[[names(method)[1]]] <- method[[1]] else {
    old <- d
    group.dfs <- split(d, d$groups)
    group.specific <- lapply(group.dfs, only.unique.vals)
    to.restore <- Reduce(intersect, lapply(group.specific, names))
    d <- method[[1]](d, debug = debug, ...)
    if (length(d) == 0) {
        return(data.frame())
    }
    else {
        check.for.columns(d, columns.to.check)
        if ("groups" %in% names(d)) {
            to.restore <- to.restore[!to.restore %in% names(d)]
            for (N in to.restore) {
                d[[N]] <- NA
                group.vec <- paste(unique(d$groups))
                for (g in group.vec) {
                  old.val <- group.specific[[g]][, N]
                  if (is.factor(old.val)) 
                    old.val <- paste(old.val)
                  d[d$groups == g, N] <- old.val
                }
            }
        }
    }
    attr(d, "orig.data") <- if (is.null(attr(old, "orig.data"))) 
        old
    else attr(old, "orig.data")
}
Browse[28]> SegCost$error <- factor(SegCost$error,c("FP","FN","E","I"))
Browse[28]> if(require(ggplot2)){
+   fp.fn.colors <- c(FP="skyblue",FN="#E41A1C",I="black",E="black")
+   fp.fn.sizes <- c(FP=2.5,FN=2.5,I=1,E=1)
+   fp.fn.linetypes <- c(FP="solid",FN="solid",I="dashed",E="solid")
+   err.df <- subset(SegCost,type!="Signal")
+ 
+   kplot <- ggplot(err.df,aes(segments,cost))+
+     geom_line(aes(colour=error,size=error,linetype=error))+
+     facet_grid(type~bases.per.probe)+
+     scale_linetype_manual(values=fp.fn.linetypes)+
+     scale_colour_manual(values=fp.fn.colors)+
+     scale_size_manual(values=fp.fn.sizes)+
+     scale_x_continuous(limits=c(0,20),breaks=c(1,7,20),minor_breaks=NULL)+
+     theme_bw()+theme(panel.margin=grid::unit(0,"lines"))
+ 
+   ## The usual ggplot without direct labels.
+   print(kplot)
+ 
+   ## Get rid of legend for direct labels.
+   no.leg <- kplot+guides(colour="none",linetype="none",size="none")
+ 
+   ## Default direct labels.
+   direct.label(no.leg)
+ 
+   ## Explore several options for tiebreaking and limits. First let's
+   ## make a qp.labels Positioning Method that does not tiebreak.
+   no.tiebreak <- list("first.points",
+                       "calc.boxes",
+                       qp.labels("y","bottom","top"))
+   direct.label(no.leg, no.tiebreak)
+ 
+   ## Look at the weird labels in the upper left panel. The E curve is
+   ## above the FN curve, but the labels are the opposite! This is
+   ## because they have the same y value on the first points, which are
+   ## the targets for qp.labels. We need to tiebreak.
+   qp.break <- qp.labels("y","bottom","top",make.tiebreaker("x","y"))
+   tiebreak <- list("first.points",
+                    "calc.boxes",
+                    "qp.break")
+   direct.label(no.leg, tiebreak)
+ 
+   ## Enlarge the text size and spacing.
+   tiebreak.big <- list("first.points",
+                        cex=2,
+                        "calc.boxes",
+                        dl.trans(h=1.25*h),
+                        "calc.borders",
+                        "qp.break")
+   direct.label(no.leg, tiebreak.big)
+ 
+   ## Even on my big monitor, the FP runs off the bottom of the screen
+   ## in the top panels. To avoid that you can specify a limits
+   ## function.
+ 
+   ## Below, the ylimits function uses the limits of each panel, so
+   ## labels appear inside the plot region. Also, if you resize your
+   ## window so that it is small, you can see that the text size of the
+   ## labels is decreased until they all fit in the plotting region.
+   qp.limited <-  qp.labels("y","bottom","top",make.tiebreaker("x","y"),ylimits)
+   tiebreak.lim <- list("first.points",
+                        cex=2,
+                        "calc.boxes",
+                        dl.trans(h=1.25*h),
+                        "calc.borders",
+                        "qp.limited")
+   direct.label(no.leg, tiebreak.lim)
+ }
Loading required package: ggplot2
debug: fp.fn.colors <- c(FP = "skyblue", FN = "#E41A1C", I = "black", 
    E = "black")
Browse[29]> 
debug: fp.fn.sizes <- c(FP = 2.5, FN = 2.5, I = 1, E = 1)
Browse[29]> 
debug: fp.fn.linetypes <- c(FP = "solid", FN = "solid", I = "dashed", 
    E = "solid")
Browse[29]> 
debug: err.df <- subset(SegCost, type != "Signal")
Browse[29]> base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv")
Browse[29]> base::cat("qp.labels", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t")
Browse[29]> ### *