Today I Learned: ____

trinker

ggplot2orBust
TIRL: I think TE showed us this a while back but I forgot to ever play with it. the sos package is a nicely formatted way of searching for R functions for a particular topic and the results are scored to help you make choices.

Code:
library(sos)
findFn("venn")
findFn("correlation")
 

trinker

ggplot2orBust
TIL: Hash tables can be created inside of a function. Previously I was under the impression that a hash table has to be created outside of a function because I thought you were creating a new environment. Not so as seen in the code below (The hash function is compliments of bryangoodrich):


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)
 

Lazar

Phineas Packard
TIL: You can nest ifelse calls. Seems somewhat obvious but never really thought about it before. For example

Code:
x<- rep(c('M', 'F', 'I'), each=10)

y<- ifelse(x=='M', 1, ifelse(x=='F', 2, 3))
 

Dason

Ambassador to the humans
TIL: .packages(all = TRUE) give a list of all the packages available to you.

You can also use library() with no parameters to get the name and a small summary of all the packages available. The function .installed.packages() gives a lot of info about each package but the output is harder to read.
 

trinker

ggplot2orBust
I knew about library() and installed.packages() but not .packages(all=TRUE). The .packages() doesn't seem to do anything on my system. Thanks for sharing.

EDIT:
Incidentally, last night I was creating a backup of all my non primary install packages and used:
Code:
list.files(.libPaths()[1])
It seems that:
Code:
list.files(.libPaths())
Is almost the same as .packages(all=TRUE)

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

Dason

Ambassador to the humans
Oops you're right! I meant to put installed.packages() and was going to move it to a different sentence describing what it does. I had it there at first but I already knew about that so I wanted to move it. Looks like I messed that post up. Time for some edits.
 

trinker

ggplot2orBust
TIL: From SO ...

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), ]
EDIT: Dason didn't see the potential for this function but he'll soon come to my way of thinking after using an advertising function he proposed earlier.
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)
EDIT 2
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)))
 

trinker

ggplot2orBust
TIL: How to make a clock (a real plot window one) in R compliments of Paul Murrell (A great resource)

Code:
library(grid)
while (TRUE) {
    grid.newpage()
    grid.text(format(Sys.time(), format="%H:%M:%S"),
    gp=gpar(cex=8))
}
Note sure of the use but fun :)
 

Dason

Ambassador to the humans
TIL: How to make a clock (a real plot window one) in R compliments of Paul Murrell (A great resource)

Code:
library(grid)
while (TRUE) {
    grid.newpage()
    grid.text(format(Sys.time(), format="%H:%M:%S"),
    gp=gpar(cex=8))
}
Note sure of the use but fun :)
But analog clocks are much more fun...
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()
 

bukharin

RoboStataRaptor
So I tried Dason's clock and after the screen flashing crazily for a few seconds I got this:
Code:
 *** caught segfault ***
address 0x0, cause 'unknown'
"For quality you can trust" indeed!! ;)
 

bryangoodrich

Probably A Mammal
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?
 

trinker

ggplot2orBust
bryangoodrich said:
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?
You can use escape on a windows machine(maybe others too) any other key stroke seems to freeze R.
 

Dason

Ambassador to the humans
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?
The only way I know of to do something like that is to use something like gWidgets.

So I tried Dason's clock and after the screen flashing crazily for a few seconds I got this:
Code:
 *** caught segfault ***
address 0x0, cause 'unknown'
"For quality you can trust" indeed!! ;)
I have no idea why that would happen. This is the first time I've used grid though.
 

Dason

Ambassador to the humans
I just tested it on my linux laptop and yeah it's pretty choppy without a Sys.sleep(1) in there. I had one originally but sometimes it would skip 2 seconds ahead so I took it out.

To make it stop make sure you're at the console and Ctrl-C should kill loop.
 

trinker

ggplot2orBust
TIL: You can left justify items using:
Code:
sprintf("%-6s", x)
An extension for me would be in using it for my discourse analysis package as seen below. I am thinking of a way to make the adding apaces to the cells and column name one smooth function. Not sure how to approach. Ideas?

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