hijack <- function (FUN, ...) {
.FUN <- FUN
args <- list(...)
invisible(lapply(seq_along(args), function(i) {
formals(.FUN)[[names(args)[i]]] <<- args[[i]]
}))
.FUN
}
.data.frame <- hijack(data.frame, check.names = FALSE, stringsAsFactors = FALSE)
(dat <- data.frame(`bad name` = 1:3, x2 = c("a", "b", "c"))); str(dat)
[COLOR="silver"]## bad.name x2
## 1 1 a
## 2 2 b
## 3 3 c
## 'data.frame': 3 obs. of 2 variables:
## $ bad.name: int 1 2 3
## $ x2 : Factor w/ 3 levels "a","b","c": 1 2 3[/COLOR]
(dat2 <- .data.frame(`bad name` = 1:3, x2 = c("a", "b", "c"))); str(dat2)
[COLOR="silver"]## bad name x2
## 1 1 a
## 2 2 b
## 3 3 c
## 'data.frame': 3 obs. of 2 variables:
## $ bad name: int 1 2 3
## $ x2 : chr "a" "b" "c"[/COLOR]
ransom <- function(text, open=TRUE) {
root <- "http://contactsheet.org/cgi-bin/ransom.pl?thedata="
text <- gsub("\\s+", "+", text)
theurl <- paste0(root, text)
require(XML)
out <- capture.output(htmlTreeParse(theurl, useInternalNodes = TRUE) )
temp <- tempdir()
outfile <- file.path(temp, "out.html")
cat(out, file=outfile)
if (open) browseURL(outfile)
return(invisible(outfile))
}
x <- "Give us your hard drives if you ever want to see your children again. Signed, The Robots."
ransom(x)
path_ <-
function(x=NULL, copy2clip = TRUE){
if (is.null(x)) x <- reports::WP()
m <- strsplit(x, "(?<=[/|\\\\])", perl=TRUE)[[1]]
o <- paste0(lapply(2*0:c(length(m)-1), function(i) paste(rep(" ", i), collapse="")), "-> ", m)
if (copy2clip) try(cat(paste(o, collapse="\n"), file="clipboard"))
invisible(paste(o, collapse="\n"))
}
Copy\CLaRI_Engineering_Literacy_Project_2014-15\META_PROJECT\IRB\Documents
-> Copy/
-> CLaRI_Engineering_Literacy_Project_2014-15/
-> META_PROJECT/
-> IRB/
-> Documents
#Fake data
x1_p <-rnorm(100)
x2_p <-rnorm(100)
x1 <- c(x1_p, x1_p + rnorm(100, 3, .2))
x2 <- c(x2_p, x2_p + rnorm(100, 3, .1))
# plot data
plot(x1, x2)
k <- 2
# random center finder
random_center <- function(){
start_x1 <- sample(seq(min(x1), max(x1), by=.02), k)
start_x2 <- sample(seq(min(x2), max(x2), by=.02), k)
split(data.frame(cbind(start_x1, start_x2)), 1:2)
}
# k-colorizing plotting function
replotter <- function(){
plot(x1, x2)
points(centers[[1]][1], centers[[1]][2], pch=19, cex=2, col="red")
points(centers[[2]][1], centers[[2]][2], pch=19, cex=2, col="blue")
cents <- do.call(rbind, centers)
text(cents[, 1], cents[, 2]+.4, labels=c("1", "2"))
}
converged <- FALSE
centers <- random_center()
assignment2 <- NULL
replotter()
# kmeans loop
while(!isTRUE(converged)){
replotter()
assignment <- unlist(Map(function(a, b) {
p<-which.min(c(
dist(cbind(c(centers[[1]][1], a), c(centers[[1]][2], b))),
dist(cbind(c(centers[[2]][1], a), c(centers[[2]][2], b)))
))
points(a, b, col = ifelse(p==1, "red", "blue"), pch=19)
p
}, x1, x2))
invisible(readline(prompt="Press [enter] to continue"))
if (length(rle(assignment)$lengths) == 1){
centers <- random_center()
} else {
centers <- lapply(split(data.frame(cbind(x1, x2)), assignment), colMeans)
if (!is.null(assignment2)) converged <- all.equal(assignment2, assignment)
assignment2 <- assignment
}
}
assignment
centers <- random_centers(k) # initialize or select random points or other start methods
while (test_convergence(...))
{
assignments <- E(centers, d) # d is the distance function to use
visualize(assignments, centers)
centers <- M(assignments, d) # optimize the centers again
visualize(assignments, centers)
}
dummy <- function(x)
{
nm <- sort(unique(x))
x <- data.frame(f = factor(x, nm, nm))
x <- model.matrix(~ 0 + f, x)
colnames(x) <- nm
x
}
diag(length(unique(x)))[rep.int(unique(x),table(x)),]
diag(length(unique(x)))[match(x,unique(x)),]