R Advanced Usage

• Types
• Environment
• Assignment
• Functions
• Dubug

library(ggplot2)

Types

In R， we have：

mode ~= class	typeof == storage.mode
numeric	double integer
character	character
logic	logical

character(2)
#  "" ""

numeric(2)
double(2)
integer(2)
# 0 0

logical(2)
# [1] FALSE FALSE
!logical(2)
# [1] TRUE TRUE

sapply(list(1:2,c(1:2),c(1,2),"hi",TRUE,1,1.5,2L), mode)
# "numeric"   "numeric"   "numeric"   "character" "logical"   "numeric"   "numeric"  "numeric" 
sapply(list(1:2,c(1:2),c(1,2),"hi",TRUE,1,1.5,2L), class)
# "integer"   "integer"   "numeric"   "character" "logical"   "numeric"   "numeric"  "integer" 
sapply(list(1:2,c(1:2),c(1,2),"hi",TRUE,1,1.5,2L), typeof)
# "integer"   "integer"   "double"    "character" "logical"   "double"    "double"   "integer"
sapply(list(1:2,c(1:2),c(1,2),"hi",TRUE,1,1.5,2L), storage.mode)
# "integer"   "integer"   "double"    "character" "logical"   "double"    "double"   "integer" 

## So, class is a weied method, double <--> numeric
## We can check it with
sapply(list(numeric(2),double(2),integer(2),logical(2),character(2)),class)
# "numeric"   "numeric"   "integer"   "logical"   "character"

sapply(list(c(), vector(), factor(), list(), matrix(), data.frame(), NULL, NA),base::mode)
# [1] "NULL"    "logical" "numeric" "list"    "logical" "list"   
# [7] "NULL"    "logical"

sapply(list(c(), vector(), factor(), list(), matrix(), data.frame(), NULL, NA),class)
# [1] "NULL"       "logical"    "factor"     "list"       "matrix"     "data.frame"
# [7] "NULL"       "logical" 

sapply(list(c(), vector(), factor(), list(), matrix(), data.frame(), NULL, NA),typeof)

# [1] "NULL"    "logical" "integer" "list"    "logical" "list"   
# [7] "NULL"    "logical"

sapply(list(c(), vector(), factor(), list(), matrix(), data.frame(), NULL, NA),storage.mode)
# [1] "NULL"    "logical" "integer" "list"    "logical" "list"   
# [7] "NULL"    "logical"

sapply(list("123","hi",TRUE,2L,1.5),as.character)
 # "123"   "hi" "TRUE"    "2"  "1.5" 

sapply(list("123","hi",TRUE,2L,1.5),as.double)
## NAs introduced by coercion
# 123.0    NA    1.0   2.0   1.5


sapply(list("123","hi",TRUE,2L,1.5),as.integer)
## NAs introduced by coercion
# 123   NA   1    2  1

sapply(list("123","hi",TRUE,2L,1.5),as.logical)
 #  NA   NA  TRUE   TRUE TRUE

is.atomic:TRUE if x is of an atomic type (or NULL)
is.recursive:TRUE if x has a recursive (list-like) structure

sapply(list(c(), vector(), factor(), list(), matrix(), data.frame(), NULL, NA),is.atomic)
# TRUE  TRUE  TRUE FALSE  TRUE FALSE  TRUE  TRUE

sapply(list(c(), vector(), factor(), list(), matrix(), data.frame(), NULL, NA),is.list)
# FALSE FALSE FALSE  TRUE FALSE  TRUE FALSE FALSE
sapply(list(c(), vector(), factor(), list(), matrix(), data.frame(), NULL, NA),is.recursive)
# FALSE FALSE FALSE  TRUE FALSE  TRUE FALSE FALSE

Environment

e1<-new.env(hash=T)
e1$a<-10
ls(e1)
# [1] "a"

## operator $ or [[
e1$a
e1[["a"]]
# [1] 10
# e1[1] !Error

attr(e1,"foo")<-10
attr(e1,"bar")<-20
e1
# <environment: 0x000000001fcd5898>
# attr(,"foo")
# [1] 10
# attr(,"bar")
# [1] 20

f<-function(n, env){ b<-get("a", envir = env); assign("a", b + n, envir = env)}

f(10,e1)
e1$a
# [1] 20
f(10,e1)
e1$a
# [1] 30

f1<-function( n ){ n + a}
environment(f1)<-e1
f1(10)
# [1] 40
f1(20)
# [1] 50
e1$a<-100

f1(20)
# 120

e1$b<-20
e1$c<-"c"
mget(c("a","b","c","d"),envir= e1,ifnotfound=NA)
# $a
# [1] 100
# $b
# [1] 20
# $c
# [1] "c"
# $d
# [1] NA

findArgs <- function(env, pattern) {
nms <- ls(envir = as.environment(env))
nms <- nms[is.na(match(nms, c("F","T")))] ## remove F && T
aa <- sapply(nms, function(.) { o <- get(.)
if(is.function(o)) names(formals(o)) }) ## indeed， all true
iw <- sapply(aa, function(a) any(grepl(pattern, a, ignore.case=TRUE)))
aa[iw]
}

body(findArgs)
# {
#     nms <- ls(envir = as.environment(env))
#     nms <- nms[is.na(match(nms, c("F", "T")))]
#     aa <- sapply(nms, function(.) {
#         o <- get(.)
#         if (is.function(o)) 
#             names(formals(o))
#     })
#     iw <- sapply(aa, function(a) any(grepl(pattern, a, ignore.case = TRUE)))
#     aa[iw]
# }
formals(findArgs)
# $env
# $pattern
names(formals(findArgs))
# "env"     "pattern"
environment(findArgs)
# <environment: R_GlobalEnv>
attributes(findArgs) 
# $srcref
# function(env, pattern) {
# nms <- ls(envir = as.environment(env))
# nms <- nms[is.na(match(nms, c("F","T")))] ## remove F && T
# aa <- sapply(nms, function(.) { o <- get(.)
# if(is.function(o)) names(formals(o)) }) ## indeed， all true
# iw <- sapply(aa, function(a) any(grepl(pattern, a, ignore.case=TRUE)))
# aa[iw]
# }

env = "package:ggplot2"
as.environment(env)
# <environment: package:ggplot2>
# attr(,"name")
# [1] "package:ggplot2"
# attr(,"path")
# [1] "D:/Program Files/R-3.4.4/library/ggplot2"
all(ls(envir = as.environment(env)) == ls(env))
# TRUE
ls(env)[82:125]
# [1] "geom_abline"     "geom_area"       "geom_bar"       
# [4] "geom_bin2d"      "geom_blank"      "geom_boxplot"   
# [7] "geom_col"        "geom_contour"    "geom_count"     
# [10] "geom_crossbar"   "geom_curve"      "geom_density"   
# [13] "geom_density_2d" "geom_density2d"  "geom_dotplot"   
# [16] "geom_errorbar"   "geom_errorbarh"  "geom_freqpoly"  
# [19] "geom_hex"        "geom_histogram"  "geom_hline"     
# [22] "geom_jitter"     "geom_label"      "geom_line"      
# [25] "geom_linerange"  "geom_map"        "geom_path"      
# [28] "geom_point"      "geom_pointrange" "geom_polygon"   
# [31] "geom_qq"         "geom_quantile"   "geom_raster"    
# [34] "geom_rect"       "geom_ribbon"     "geom_rug"       
# [37] "geom_segment"    "geom_smooth"     "geom_spoke"     
# [40] "geom_step"       "geom_text"       "geom_tile"      
# [43] "geom_violin"     "geom_vline" 
formals(get(ls(env)[84]))
# $mapping
# NULL
# $data
# NULL
# $stat
# [1] "count"
# $position
# [1] "stack"
# $...
# 
# $width
# NULL
# $binwidth
# NULL
# $na.rm
# [1] FALSE
# $show.legend
# [1] NA
# $inherit.aes
# [1] TRUE

findArgs("package:ggplot2","colours")
# $scale_color_gradientn
# [1] "..."      "colours"  "values"   "space"    "na.value" "guide"   
# [7] "colors"  
# 
# $scale_colour_gradientn
# [1] "..."      "colours"  "values"   "space"    "na.value" "guide"   
# [7] "colors"  
# 
# $scale_fill_gradientn
# [1] "..."      "colours"  "values"   "space"    "na.value" "guide"   
# [7] "colors" 

Assignment

v1 <- v2 <- 5 -> v3
identical(v1,v2,v3)
# TRUE

Assign a value to a name in an environment

for(i in 1:5){
    nam <- paste("var", i, sep = "")
    assign(nam, 1:i)
}
ls(pattern = "^var.$")
# "var1" "var2" "var3" "var4" "var5"
get(paste("var", 5, sep = ""))
# 1 2 3 4 5
deparse(var5)
# "1:5"
substitute(var5)
# var5
assign("var5[5]", 1)
var5[5]
# 5
`var5[5]`
get("var5[5]")
# 1

In R, We have <- VS = assignment operators, the main difference is the scope

rm(x)

## Warning in rm(x): 找不到对象'x'

mean(x=1:10)
# x
## Error: object 'x' not found
mean(x <- 1:10)
x
# [1]  1  2  3  4  5  6  7  8  9 10

Functions

a <- 1
f <- function(a) return(a <- a + 1)
f2 <- f(a <- a + 5)
a
# 6
f2
# 7

a = 1
f <- function(a) return(a <-  a + 1 )
f2 <- f(a = a + 5)
a
# 1
f2
# 7

a <- 1
f <- function(a) return(a <<- a + 1)
f2 <- f(a = a + 5)
a
# 7
f2
# 7

Scheme Perl Python Common Lisp (all languages converge to Lisp) Lexical scope

make.power <- function(n) {
        pow <- function(x) {
                x^n 
        }
        pow 
}
cube <- make.power(3)
square <- make.power(2)
cube(4)
square(3)
# 64
# 9

ls(environment(cube))
# "n"   "pow"
get("n", environment(cube))
# 3
ls(environment(square))
# "n"   "pow"
get("n", environment(square))
# 2

n <- function(x) x * 2
 foo <- function() {
     n <- 5
     n(n) 
 }
 foo()

fun <- function(param1, param2 = c("SEL1", "SEL2", "SEL3"), ...) {
     if (missing(param1)) {
         stop("param1 is required.")
     }
     if (!inherits(param1, c("numeric", "integer", "double"))) {
         stop("param1 must be an object of numeric")
     }
     param2 <- match.arg(param2)
     if (!missing(...)) {
         dots <- substitute(list(...))[-1]
         names <- unlist(sapply(dots, deparse))
         return(names)
     } else {
         return(invisible(quantile(param1)))
     }
}
fun(param1 = 1:10, param2 = "SEL2")
res <- fun(param1 = 1:10, param2 = "SEL2")
res
#   0%   25%   50%   75%  100% 
# 1.00  3.25  5.50  7.75 10.00 
fun(param1 = 1:10, param2 = "SEL3", otherParam = "It returned!!!")
#           otherParam 
# "\"It returned!!!\"" 

Dubug

Insert this into your code at the place where you want to start debugging:

browser()

When the R interpreter reaches that line, it will pause your code and you will be able to look at and change variables.

In the browser, typing these letters will do things:

c	Continue
n (or Return)	Next step
Q	quit
Ctrl-C	go to top level

To pause and start a browser for every line in your function:

# debug(myfunction)
# myfunction(x)

By default, every time you press Enter at the browser prompt, it runs the next step. This is equivalent to pressing n and then Enter. This can be annoying. To disable it use:

options(browserNLdisabled=TRUE)
getOption("defaultPackages")

To start debugging whenever an error is thrown, run this before your function which throws an error:

options(error=recover)

If you want these options to be set every time you start R, you can put them in your ~/.Rprofile file.