## Programming 101 ## Author: Adrian Waddell ## Date: Nov. 9th, 2012 ## Grouped Expressions a <- b <- c <- 5 d <- {a <- 3; b <- a+5 c <- b*2} d ## Conditions x <- FALSE foo <- function(x) { if(x) { cat("Condition was TRUE\n") } else { cat("Condition was FALSE\n") } } foo(x=TRUE) foo(x=FALSE) mySqrt <- function(x) { if(x>=0){ result <- sqrt(x) } else { warning("returned sqrt of abs. value") result <- sqrt(abs(x)) } return(result) } mySqrt(x=7) mySqrt(x=-7) ## The value of a grouped expression is the result of the ## last expression in the group evaluated. ## so this function will behave the same mySqrt <- function(x) { if(x>=0){ sqrt(x) } else { warning("returned sqrt of abs. value") sqrt(abs(x)) } } mySqrt(x=7) mySqrt(x=-7) ## if does not act elementwise if(c(FALSE,FALSE,TRUE)) { 5 } else { 6 } ## However ifelse is an elementwise expression ifelse(c(FALSE,FALSE,TRUE),5,6) ## Hence use "short-circuit" logical operators && and || a <- 8; b <- 4 if(a>3 && b<3) { cat("condition is TRUE\n") } else { cat("condition is FALSE\n") } ?Syntax ## do not forget Operator precedence ## Multiple if's if(a > 2) { 1 } else if(a>3) { 2 } else { 3 } apropos('^is\\.') is.empty(logical(0)) ## For loops for(i in 1:10) { cat(paste('run',i,'\n')) } { i <- 1 cat(paste('run',i,'\n')) } { i <- 2 cat(paste('run',i,'\n')) } { i <- 3 cat(paste('run',i,'\n')) } for(i in 1:10) { cat(paste('run',i,'\n')) Sys.sleep(1) } ## more on for loops a <- .77; b <- .32 x <- c(0.2, 0.11, rep(0,98)) for(i in 3:length(x)) { x[i] <- (a*x[i-1]+b*sqrt(x[i-2]))^2 } x ## this works too x <- c(0.2, 0.11) for(i in 3:100) { x[i] <- (a*x[i-1]+b*sqrt(x[i-2]))^2 } ## or x <- c(0.2, 0.11) for(i in 3:100) { x <- c(x, (a*x[i-1]+b*sqrt(x[i-2]))^2) } x ## How long does it take ?'system.time' system.time({ x <- c(0.2, 0.11, rep(0,100000-2)) for(i in 3:length(x)) { x[i] <- (a*x[i-1]+b*sqrt(x[i-2]))^2 } }) system.time({ x <- c(0.2, 0.11) for(i in 3:100000) { x[i] <- (a*x[i-1]+b*sqrt(x[i-2]))^2 } }) system.time( { x <- c(0.2, 0.11) for(i in 3:100000) { x <- c(x, (a*x[i-1]+b*sqrt(x[i-2]))^2) } }) ## while loop i <- 0 while(i<4){ cat('run with i=',i,'\n') i <- i+1 } ## sapply ?sapply sapply(1:3, FUN = function(x) { x^2 }) lapply(1:3, FUN = function(x) { x^2 }) library(AER) data(Journals) sapply(Journals, FUN = function(x) { is.factor(x) }) sapply(Journals,is.factor) ## Compare sapply, for and vectorbased r <- runif(100000) system.time({ o <- sapply(X=r, FUN = function(x) { if(x < 0.3) { 1 } else if(x < 0.5) { 2 } else if(x < 0.7) { 3 } else { 4 } }) }) plot(r,col=c('#E2307E','#A885B9','#F8C850','#C4D5A5')[o],pch=19,cex=2) abline(h=c(0.3,0.5,0.7), lwd = 2, col = '#28457C') ## same grouping with for loop system.time({ ofor <- rep(-1,length(r)) for(i in 1:length(r)) { if(r[i] < 0.3) { ofor[i] <- 1 } else if(r[i] < 0.5) { ofor[i] <- 2 } else if(r[i] < 0.7) { ofor[i] <- 3 } else { ofor[i] <- 4 } } }) ## or system.time({ oassign <- rep(4,length(r)) oassign[r < 0.3] <- 1 oassign[r >= 0.3 & r < 0.5 ] <- 2 oassign[r>= 0.5 & r < 0.7] <- 3 }) all.equal(o,ofor,oassign) all(o == ofor) any(o != ofor) ## Apply ?apply mat <- matrix(c(1,1,1, 3,2,4, 2,2,4, 6,6,1), byrow = TRUE, ncol = 3) mat apply(X=mat, MARGIN=1, FUN=function(row){ mean(row)*sd(row) }) apply(mat,2,sum) ## tapply ?tapply with(Journals,tapply(price,field,mean)) names(Journals) ## Functions rm(list=ls()) foo <- function(a,b){ sqrt(sum(a^2,b^2)) } foo(a=3,b=4) ## Default Arguments multiply <- function(x,y, elementwise=TRUE) { if(elementwise) { return(x*y) } else { return(sum(x*y)) } } multiply(x=c(1,4,2), y=c(3,4,1)) multiply(x=c(1,4,2), y=c(3,4,1), elementwise=FALSE) ## Named Arguments foo <- function(a,b,c=1,d=10,e=10^2,f=10^3,g=10^4) { a+b+c+d+e+f+g } foo(a=0,b=0) foo(0,0) foo(0.1,0.01,0) foo(0.1,0.01,0,0) foo(0.1,0.01,0,f=0) foo(0.1,0.01,0,f=0,0) ## Ellipsis myPlot <- function(x,y,...) { dev.new(pointsize=18) par(mai = c(1,1,1,1)/2) plot(x,y, type='n', xlab='', ylab='', axes=FALSE, ...) box(col='#E2307E', lwd=4) points(x,y, pch = 16, ...) } cols <- paste(c('#C4D5A5','#A885B9','#F8C850','#28457C'),'55',sep='') with(iris, myPlot(Sepal.Length,Petal.Width, col=cols, cex=3)) ## Global and Local Variables rm(list = ls()) foo <- function(){a <- 3} foo() ls() foo <- function(){a <<- 3} foo() ls() ## Scoping rm(list = ls()) search() a <- 5 parent.env(environment()) foo <- function() { cat('foo has environemt\n') show(environment()) a <- 2 bar <- function() {a} bar() } bar <- function(x) { cat('bar has environemt\n') show(environment()) cat('bar has parent environemt\n') show(parent.env(environment())) a } ## Example on slides a <- 5 foo <- function() { a <- 3 bar() } bar <- function() { a } foo() ## Next Example foo <- function() { a <- 3 bar <- function() { a*a } bar() } foo() ## Namespaces ?search search() ?c ## look out for c {base} in the upper left corner c <- function() {5} c() c(2,3) rm(c) c(2,3) ls(name="package:base")[1:40] c <- function() {5} base::c(2,3) c(2,3) ## Object Oriented Model: S3 summary fit <- lm(Sepal.Length~Sepal.Width, data=iris) class(fit) summary(fit) summary(iris) class(iris) ## Dog example Wuffy <- list(name="Wuffy", age=5) class(Wuffy) <- c("dog","animal") Tom <- list(name="Tom", age=3) class(Tom) <- c("cat","animal") age <- function(x) { UseMethod("age") } age.animal <- function(x) { x$age } age.default <- function(x) { cat("Age is not defined for your object!\n") } age(Wuffy) age(Tom) age(iris) talk <- function(x) { UseMethod("talk") } talk.dog <- function(x) { cat("Wuff Wuff!\n") } talk.cat <- function(x) { cat("Miaow!\n") } talk.default <- function(x) { cat("*Silence*\n") } talk(Wuffy) talk(Tom) talk(4) methods(talk) methods("cat") ?methods ## ## Stuff I did not cover in the slides ## ## Recursive functions factorial <- function(n) { if(n == 0) { return(1) } else { return(n*factorial(n-1)) } } factorial(100) ## with lookup lookup <- rep(-1,10) factorial <- function(n) { if(n == 0) { return(1) } else if(n > length(lookup)) { lookup <<- c(lookup,rep(-1,n-length(lookup)+10)) lookup[n] <<- n*factorial(n-1) } else if(lookup[n] == -1) { lookup[n] <<- n*factorial(n-1) } return(lookup[n]) } factorial(5) factorial(10) factorial(15) lookup n <- 15 prod(1:n) ## also factorial