Skip to content

Instantly share code, notes, and snippets.

View robertzk's full-sized avatar

Robert Krzyzanowski robertzk

131 followers · 64 following
View GitHub Profile
@robertzk
robertzk / gist:7816312
Created December 5, 2013 23:53
`||` <- function(a,b) if(is.null(a)) b else base::`||`(a,b)
@robertzk
robertzk / gist:7816384
Created December 6, 2013 00:01
R exercise: http://adv-r.had.co.nz/Functions.html Create a list of all the replacement functions found in the base package. Which ones are primitive functions?
x <- ls("package:base")
x[substring(x, nchar(x)-1, nchar(x)) == '<-']
# "[[<-" "[<-" "@<-" "<-" "<<-" "$<-" "attr<-" "attributes<-" "body<-" "class<-" "colnames<-" "comment<-" "diag<-" "dim<-"
# "dimnames<-" "Encoding<-" "environment<-" "formals<-" "is.na<-" "length<-" "levels<-" "mode<-" "mostattributes<-" "names<-" "oldClass<-" "parent.env<-" "regmatches<-" "row.names<-"
# "rownames<-" "split<-" "storage.mode<-" "substr<-" "substring<-" "units<-"
@robertzk
robertzk / xor.r
Created December 6, 2013 00:05
R exercise: Create an infix xor() operator. http://adv-r.had.co.nz/Functions.html
`%xor%` <- function(x,y) (x || y) && !(x && y)
@robertzk
robertzk / infixed.r
Created December 6, 2013 00:33
R exercise: Create infix versions of set functions: intersect(), union(), setdiff() http://adv-r.had.co.nz/Functions.html
infixed_names <- list(intersect = '∩', union = 'U', setdiff = '-')
create_infix_operator <- function(name, base_fn, e) {
name <- paste("%", name, "%", sep = '')
assign(name, function(x, y) get(base_fn, envir = e)(x, y), envir = e)
}
lapply(names(infixed_names), function(name) {
create_infix_operator(infixed_names[[name]], name, e = parent.frame(2))
})
@robertzk
robertzk / randomreplace.r
Created December 6, 2013 00:36
R exercise: Create a replacement function that modifies a random location in vector. http://adv-r.had.co.nz/Functions.html
"random<-" <- function(object, position, value) {
object[sample(seq_along(object), 1)] <- value
object
}
# Example:
# > x <- c(1,2,3,4,5)
# > random(x) <- 10
# > x
# [1] 1 10 3 4 5
@robertzk
robertzk / get.r
Last active December 30, 2015 12:48
R exercise: Write your own version of get() using a function written in the style of where(). http://adv-r.had.co.nz/Environments.html
get <- function(name, env = parent.frame()) {
if (identical(env, emptyenv())) stop(name, ' not found')
if (exists(name, env = env, inherits = FALSE)) return(env[[name]])
else get(name, parent.env(env))
}
@robertzk
robertzk / fget.r
Created December 6, 2013 22:41
R exercise: Write a function called fget() that finds only function objects. It should have two arguments, name and env, and should obey the regular scoping rules for functions: if there's an object with a matching name that's not a function, look in the parent. (This function should be a equivalent to match.fun() extended to take a second argum…
fget <- function(name, env = parent.frame(), inherits = TRUE) {
if (identical(env, emptyenv())) stop(name, ' not found')
if (exists(name, env = env, inherits = FALSE) && is.function(tmp <- env[[name]])) return(tmp)
else if (inherits) fget(name, parent.env(env))
else stop(name, ' not found')
}
@robertzk
robertzk / exists.r
Created December 6, 2013 22:48
R exercise: Write your own version of exists(inherits = FALSE) (Hint: use ls()). Write a recursive version that behaves like inherits = TRUE. http://adv-r.had.co.nz/Environments.html
exists <- function(name, env = parent.frame(), inherits = TRUE) {
if (identical(env, emptyenv())) return(FALSE)
if (name %in% ls(envir = env)) TRUE
else if (inherits) exists(name, parent.env(env))
else FALSE
}
@robertzk
robertzk / mystery_method.rb
Created January 10, 2014 01:19
def mystery_method(x)
->(z) do
x.inject(z) { |f, v| f(v) }
end
end
@robertzk
robertzk / gist:9627546
Created March 18, 2014 19:28
# Reload the suite of Syberia packages. This will be automated later.
require(devtools)
pkgs <- strsplit("Ramd productivus stagerunner statsUtils mungebitsTransformations mungebits tundra syberia", " ")[[1]]
lapply(list(
list(function(x) if(x %in% loadedNamespaces()) unloadNamespace(x), rev = TRUE),
list(install_github, 'robertzk'),
list(library, character.only = TRUE)
), function(x) { r <- x$rev; x$rev <- NULL; do.call(lapply, append(list(if (is.null(r)) pkgs else rev(pkgs)), x)) })