Code:

```
require(plyr)
qview(baseball)
TEST <- baseball[, c("id", "team")]
TEST <- TEST[!duplicated(TEST$id), ]
hash <- function(x, type = "character") {
e <- new.env(hash = TRUE, size = nrow(x), parent = emptyenv())
char <- function(col) assign(col[1], as.character(col[2]), envir = e)
num <- function(col) assign(col[1], as.numeric(col[2]), envir = e)
FUN <- if(type=="character") char else num
apply(x, 1, FUN)
return(e)
}
FUN <- function(DF, vector){
new_env <- hash(DF[sample(nrow(DF), 1000), ])
type <- function(x) if(exists(x, env = new_env))get(x, e = new_env) else NA
unlist(lapply(vector, type))
}
FUN(TEST, baseball$id)
```

Incidentally, last night I was creating a backup of all my non primary install packages and used:

Code:

`list.files(.libPaths()[1])`

Code:

`list.files(.libPaths())`

To make .packages() show something wrap it with parenthesis. It actually shows what packages are currently loaded:

Code:

`(.packages())`

menu can be used more as a gwidgets type interface. It's pretty cool : )

Code:

```
df <- data.frame(a=1:100,b=runif(100))
df[menu(apply(df,1,paste,collapse=" "), graphics=TRUE), ]
```

Code:

```
gcf <- function(..., specialmessage = TRUE){
# Make a vector
nums <- c(...)
# Create a vector of divisors to try
divs <- 1:min(nums)
# Create a matrix of whether the divisor goes into each number
idx <- do.call(rbind, lapply(nums, function(x){!(x %% divs)}))
if(specialmessage){
menu(c("Yes!!! Tell me more about cheap viagra.",
"No Thanks. I don't like cheap viagra."),
title = "Do you want viagra?",
graphics=TRUE)
plot.new()
par(mar = rep(0, 4),xpd=NA)
mess <- paste(rep("CHEAP VIAGRA WWW.CHEAPVIAGRASRSLYLOLS.EDU\n", 40), collapse="")
text(.475, .8, mess)}
par(mar = c(5, 4, 4, 2) + 0.1)
# Figure out the 'furthest' column that has all of the rows true
return(max(which(apply(idx, 2, all))))
}
gcf(c(10, 12, 24))
gcf(20, 25)
gcf(10, 8)
gcf(1000, 999)
gcf(222*17, 222*109, 222*2342)
```

I added a title to the menu with the title = argument.

Also I found out select.list() is exactly like menu with the graphics = TRUE but instead of returning the numeric rank on the list it returns a character string version of what ever was selected from the list.

Code:

`select.list(title = "packages", sort(.packages(all.available = TRUE)))`

Code:

```
library(grid)
while (TRUE) {
grid.newpage()
grid.text(format(Sys.time(), format="%H:%M:%S"),
gp=gpar(cex=8))
}
```

Code:

```
library(grid)
while (TRUE) {
grid.newpage()
grid.text(format(Sys.time(), format="%H:%M:%S"),
gp=gpar(cex=8))
}
```

Code:

```
library(grid)
getHour <- function(time){
as.numeric(format(time, format = "%H")) %% 12
}
getMinute <- function(time){
as.numeric(format(time, format = "%M"))
}
getSecond <- function(time){
as.numeric(format(time, format = "%S"))
}
drawClock <- function(brandname = "Dason's Friendly\n Clock Co.", majorTicks = TRUE, minorTicks = TRUE){
grid.newpage()
# Create outer circle, fill here gives color between this and inner circle
grid.circle(x = .5, y = .5, r = .5, gp = gpar(fill = "white"))
# Create inner circle, fill here gives color of inside of clock
grid.circle(x = .5, y = .5, r = .45, gp = gpar(fill = "lightgray"))
# Create center dot
grid.circle(x = .5, y = .5, r = .01, gp = gpar(fill = "black"))
# Add a brandname. For quality you can trust
# Choose "Dason's Friendly Clock Co."
grid.text(brandname, x = .5, y = .7, gp = gpar(cex = 1.3))
# Add text for the Hours
for(i in 1:12){
txt <- as.character(i)
ang <- pi/2 - 2*pi/12*i
x <- .5 + .475*cos(ang)
y <- .5 + .475*sin(ang)
grid.text(txt, x=x, y=y)
}
# Add small ticks at quarter hours
if(minorTicks){
numticks <- 60
for(i in 1:numticks){
ang <- pi/2 - 2*pi/numticks*i
x <- c(.5 + .425*cos(ang), .5+.45*cos(ang))
y <- c(.5 + .425*sin(ang), .5+.45*sin(ang))
grid.lines(x, y)
}
}
# Add larger ticks at the hour
if(majorTicks){
for(i in 1:12){
ang <- pi/2 - 2*pi/12*i
x <- c(.5 + .40*cos(ang), .5+.45*cos(ang))
y <- c(.5 + .40*sin(ang), .5+.45*sin(ang))
grid.lines(x, y, gp = gpar(lex = 2))
}
}
}
drawHands <- function(time, seconds = TRUE){
min <- getMinute(time)
min.ang <- pi/2 - 2*pi/60*min
min.x <- c(.5 - .05*cos(min.ang), .5 + .420*cos(min.ang))
min.y <- c(.5 - .05*sin(min.ang), .5 + .420*sin(min.ang))
grid.lines(min.x, min.y, arrow = arrow(), gp = gpar(lex = 2))
hr <- getHour(time)
hr.ang <- pi/2 - 2*pi/12*hr - 2*pi/12*min/60
hr.x <- c(.5 - .05*cos(hr.ang), .5 + .3*cos(hr.ang))
hr.y <- c(.5 - .05*sin(hr.ang), .5 + .3*sin(hr.ang))
grid.lines(hr.x, hr.y, arrow = arrow(), gp = gpar(lex = 3))
if(seconds){
sec <- getSecond(time)
sec.ang <- pi/2 - 2*pi/60*sec
sec.x <- c(.5 - .05*cos(sec.ang), .5 + .475*cos(sec.ang))
sec.y <- c(.5 - .05*sin(sec.ang), .5 + .475*sin(sec.ang))
grid.lines(sec.x, sec.y, gp = gpar(lex = 1))
}
}
analogClock <- function(displaySeconds = TRUE, minorTicks = TRUE, majorTicks = TRUE, ...){
while(TRUE){
drawClock(minorTicks = minorTicks, majorTicks = majorTicks, ...)
drawHands(Sys.time(), seconds = displaySeconds)
}
}
analogClock()
```

Trinker, since you're only displaying seconds, you might as well put a Sys.sleep(1) in there; otherwise, it just blinks a lot on my slow PC. Is there any way to listen for a user input to cancel the clock? Like, once any key is pressed, turn off the device and break out of the loop?

So I tried Dason's clock and after the screen flashing crazily for a few seconds I got this:
"For quality you can trust" indeed!!

Code:

```
*** caught segfault ***
address 0x0, cause 'unknown'
```

Code:

`sprintf("%-6s", x)`

Code:

```
#Fake Text:
questions <- c("I ARGUE A LOT", "I BRAG", "I AM MEAN TO OTHERS", "I TRY TO GET A LOT OF ATTENTION",
"I DESTROY MY OWN THINGS", "I DESTROY THINGS BELONGING TO OTHERS",
"I DISOBEY MY PARENTS", "I DISOBEY AT SCHOOL", "I AM JEALOUS OF OTHERS",
"I GET IN MANY FIGHTS", "I PHYSICALLY ATTACK PEOPLE", "I SCREAM A LOT",
"I SHOW OFF OR CLOWN", "I AM STUBBORN", "MY MOODS OR FEELINGS CHANGE SUDDENLY",
"I TALK TOO MUCH", "I TEASE OTHERS A LOT", "I HAVE A HOT TEMPER",
"I THREATEN TO HURT PEOPLE", "I AM LOUDER THAN OTHER KIDS")
# the junky way the dataframe looks
(DF1 <- data.frame(x1 = questions, x2 = 1:20))
#function to justify
left.just <- function(x){
n <- max(nchar(x))
return(sprintf(paste("%-", n, "s", sep=""), x))
}
#Now lets use the function to generate a better looking dataframe without using latex
DF2 <- data.frame(x1 = left.just(questions), x2 = 1:20)
names(DF2)[1] <- sprintf("%-36s", names(DF2)[1])
DF2
```