├── NAMESPACE ├── DESCRIPTION ├── inst ├── flock.gif ├── gravity.gif └── blackhole.gif ├── R ├── scatterdeconstruct.gif ├── deconstructr.plot.R ├── aniloop.blackhole.R ├── aniloop.gravity.R └── aniloop.flock.R ├── demo ├── demo.blackhole.R ├── demo.flock.R └── demo.gravity.R └── README.md /NAMESPACE: -------------------------------------------------------------------------------- 1 | export("gravity") 2 | export("blackhole") 3 | 4 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: deconstructR 2 | Version: 0.1 3 | Depends: animation -------------------------------------------------------------------------------- /inst/flock.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/brandmaier/deconstructR/HEAD/inst/flock.gif -------------------------------------------------------------------------------- /inst/gravity.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/brandmaier/deconstructR/HEAD/inst/gravity.gif -------------------------------------------------------------------------------- /inst/blackhole.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/brandmaier/deconstructR/HEAD/inst/blackhole.gif -------------------------------------------------------------------------------- /R/scatterdeconstruct.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/brandmaier/deconstructR/HEAD/R/scatterdeconstruct.gif -------------------------------------------------------------------------------- /demo/demo.blackhole.R: -------------------------------------------------------------------------------- 1 | library(deconstructR) 2 | 3 | set.seed(234) 4 | N <- 20 5 | x <- rnorm(N) 6 | y <- rnorm(N)+0.3*x 7 | 8 | xlab <- "Perceptual Speed" 9 | ylab <- "Alpha Peak Frequency" 10 | 11 | 12 | blackhole(x,y, xlab=xlab, ylab=ylab) 13 | 14 | 15 | -------------------------------------------------------------------------------- /demo/demo.flock.R: -------------------------------------------------------------------------------- 1 | library(deconstructR) 2 | 3 | set.seed(234) 4 | N <- 20 5 | x <- rnorm(N) 6 | y <- rnorm(N)+0.3*x 7 | 8 | xlab <- "Chronic Functional Limitations" 9 | ylab <- "Depressive Affect" 10 | 11 | 12 | flock(x,y, xlab=xlab, ylab=ylab) 13 | 14 | 15 | -------------------------------------------------------------------------------- /demo/demo.gravity.R: -------------------------------------------------------------------------------- 1 | library(deconstructR) 2 | 3 | set.seed(234) 4 | N <- 20 5 | x <- rnorm(N) 6 | y <- rnorm(N)+0.3*x 7 | 8 | xlab <- "Chronic Functional Limitations" 9 | ylab <- "Depressive Affect" 10 | 11 | 12 | gravity(x,y, xlab=xlab, ylab=ylab) 13 | 14 | 15 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # deconstructR 2 | 3 | An R package for deconstructing scatter plots. Currently, three animated plots are provided: `blackhole`, `flock`, and `gravity`. Here is a simple example: 4 | 5 | ```{r, eval=FALSE} 6 | set.seed(234) 7 | N <- 20 8 | x <- rnorm(N) 9 | y <- rnorm(N)+0.3*x 10 | 11 | xlab <- "Chronic Functional Limitations" 12 | ylab <- "Depressive Affect" 13 | 14 | 15 | gravity(x,y, xlab=xlab, ylab=ylab) 16 | ``` 17 | 18 | ![gravity](https://github.com/brandmaier/deconstructR/blob/master/inst/gravity.gif?raw=true) 19 | 20 | # Other plot types 21 | 22 | Check our other plots: 23 | 24 | Flock plot 25 | 26 | ![flock](https://github.com/brandmaier/deconstructR/blob/master/inst/flock.gif?raw=true) 27 | 28 | Blackhole 29 | 30 | ![flock](https://github.com/brandmaier/deconstructR/blob/master/inst/blackhole.gif?raw=true) -------------------------------------------------------------------------------- /R/deconstructr.plot.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | deconstructr.plot <- function(x,y, xlim=NULL, ylim=NULL,xlab=NULL, 4 | ylab=NULL, movie.name=NULL, type="gravity") { 5 | 6 | 7 | if (is.null(movie.name)) { 8 | movie.name <- "scatterdeconstruct.gif" 9 | } 10 | 11 | 12 | if (is.null(xlim)) 13 | xlim <- c(min(x),max(x)) 14 | 15 | if (is.null(ylim)) 16 | ylim <- c(min(y),max(y)) 17 | 18 | height <- ylim[2]-ylim[1] 19 | floory <- ylim[1] 20 | freeze <- rep(FALSE, N) 21 | 22 | 23 | if (type == "blackhole") { 24 | fun <- aniloop.blackhole 25 | } else if (type =="gravity") { 26 | fun <- aniloop.gravity 27 | } else if (type == "flock") { 28 | fun <- aniloop.flock 29 | } else { 30 | stop("Unknown type!") 31 | # return(); 32 | } 33 | 34 | 35 | saveGIF( fun(x,y,xlim,ylim,xlab,ylab), 36 | interval=0.05, movie.name=movie.name, 37 | ani.width=600) 38 | 39 | } -------------------------------------------------------------------------------- /R/aniloop.blackhole.R: -------------------------------------------------------------------------------- 1 | blackhole <- function(x,y, xlim=NULL, ylim=NULL,xlab=NULL, ylab=NULL, movie.name=NULL) 2 | { 3 | deconstructr.plot(x,y,xlim, ylim, xlab, ylab, movie.name=movie.name, type="blackhole") 4 | } 5 | 6 | getAngle <- function(x1,y1,x2,y2) { 7 | #return( atan2(y1,x1)-atan2(y2,x2)) 8 | return( atan2(y2-y1,x2-x1)) 9 | } 10 | 11 | aniloop.blackhole <- function(x,y,xlim,ylim,xlab,ylab, frames=60, stillframe=20) { 12 | 13 | totalframes <- frames+2*stillframe 14 | 15 | 16 | angle <- rep(NA, length(x)) 17 | 18 | center.x <- (max(x)+min(x))/2 19 | center.y <- (max(y)+min(y))/2 20 | 21 | oangle <- getAngle(center.x, center.y, x, y) 22 | 23 | speed <- rep(.01 * (max(x)-min(x)) ,length(x)) 24 | 25 | for (i in 1:totalframes) { 26 | 27 | 28 | 29 | plot(x,y,xlim=xlim,ylim=ylim, xlab=xlab, ylab=ylab) 30 | 31 | 32 | if (i <= stillframe) { 33 | next 34 | } 35 | 36 | if (i > stillframe+frames) { 37 | next 38 | } 39 | angle <- getAngle(center.x, center.y, x, y) 40 | 41 | x <- x - cos(angle)*speed 42 | y <- y - sin(angle)*speed 43 | 44 | stopped <- (sign(angle)!=sign(oangle)) 45 | 46 | if (any(stopped)) { 47 | speed[stopped] <- 0 48 | x[stopped] <- center.x 49 | y[stopped] <- center.y 50 | } 51 | 52 | speed <- speed * 1.1 53 | 54 | } 55 | 56 | } -------------------------------------------------------------------------------- /R/aniloop.gravity.R: -------------------------------------------------------------------------------- 1 | 2 | #' Gravity plot function 3 | #' 4 | #' @param x 5 | #' @param y 6 | #' @param xlim 7 | #' 8 | gravity <- function(x,y, xlim=NULL, ylim=NULL,xlab=NULL, ylab=NULL, movie.name=NULL) 9 | { 10 | deconstructr.plot(x,y,xlim, ylim, xlab, ylab,movie.name=movie.name, type="gravity") 11 | } 12 | 13 | 14 | aniloop.gravity <- function(x,y,xlim,ylim, xlab,ylab, frames=60, stillframe=20) { 15 | 16 | totalframes <- frames+2*stillframe 17 | 18 | speedy <- rep(0, N) 19 | 20 | bouncyness <- 0.5 #0.3 21 | 22 | for (i in 1:totalframes) { 23 | 24 | 25 | plot(x,y,xlim=xlim,ylim=ylim, xlab=xlab, ylab=ylab) 26 | 27 | model <- lm(y~x) 28 | abline(model, lty=1) 29 | p <- round(cor.test(x,y)$p.value,2) 30 | # legend("topright", legend = paste("p=",p,sep=""),border = FALSE,bty = "n") 31 | 32 | floory <- ylim[1] 33 | height <- ylim[2]-ylim[1] 34 | 35 | if (i <= stillframe) { 36 | next 37 | } 38 | 39 | if (i > stillframe+frames) { 40 | next 41 | } 42 | 43 | y <- y + speedy 44 | 45 | onfloor <- (y <= (floory+0.01*height)) 46 | 47 | # increase speed (accelerate) 48 | speedy[!onfloor] <- speedy[!onfloor] - runif(N,0,height*0.02) 49 | 50 | # bounce 51 | speedy[onfloor] <- -speedy[onfloor]*bouncyness 52 | 53 | #speedy[onfloor] <- ifelse(abs(speedy[onfloor]<0.2,0,speedy[onfloor])) 54 | y[onfloor] <- floory 55 | 56 | #if (i > stillframe+10) { 57 | # freeze <- freeze | (abs(speedy) < 0.5) 58 | #} 59 | 60 | 61 | 62 | } 63 | 64 | 65 | } 66 | 67 | -------------------------------------------------------------------------------- /R/aniloop.flock.R: -------------------------------------------------------------------------------- 1 | 2 | #' Flock plot function based on Craig Reynolds (1986) flocking algorithm 3 | #' 4 | #' @param x 5 | #' @param y 6 | #' @param xlim 7 | #' 8 | flock <- function(x,y, xlim=NULL, ylim=NULL,xlab=NULL, ylab=NULL, movie.name=NULL) 9 | { 10 | deconstructr.plot(x,y,xlim, ylim, xlab, ylab,movie.name=movie.name, type="flock") 11 | } 12 | 13 | 14 | aniloop.flock <- function(x,y,xlim,ylim, xlab,ylab, frames=80, stillframe=20) { 15 | 16 | num.elems <- length(x) 17 | 18 | totalframes <- frames+2*stillframe 19 | 20 | vel.x <- rnorm(n = num.elems) 21 | vel.y <- rnorm(n = num.elems) 22 | 23 | for (i in 1:totalframes) { 24 | 25 | plot(x,y,xlim=xlim,ylim=ylim, xlab=xlab, ylab=ylab) 26 | 27 | # distance matrix 28 | D <-as.matrix( dist(cbind(x,y))) 29 | 30 | # init 31 | rule1.vel.x <- rep(0, num.elems) 32 | rule1.vel.y <- rep(0, num.elems) 33 | rule2.vel.x <- rep(0, num.elems) 34 | rule2.vel.y <- rep(0, num.elems) 35 | 36 | # (1) align 37 | 38 | for (j in 1:num.elems) { 39 | neighbors <- which(D[, j]<.2) # neighbors incl. self 40 | rule1.vel.x[j] <- sum(vel.x[neighbors]) 41 | rule1.vel.y[j] <- sum(vel.y[neighbors]) 42 | # normalize 43 | vnorm <- sqrt(rule1.vel.x[j]*rule1.vel.x[j]+rule1.vel.y[j]*rule1.vel.y[j]) 44 | rule1.vel.x[j] <- rule1.vel.x[j] / vnorm 45 | rule1.vel.y[j] <- rule1.vel.y[j] / vnorm 46 | } 47 | 48 | # (2) separation 49 | for (j in 1:num.elems) { 50 | neighbors <- which(D[, j]<.1) # neighbors incl. self 51 | for (k in neighbors) { 52 | # if (k==j) next; 53 | rule2.vel.x[j] <- rule2.vel.x[j]+ x[k]-x[j] 54 | rule2.vel.y[j] <- rule2.vel.y[j]+ y[k]-y[j] 55 | } 56 | } 57 | 58 | # invert 59 | rule2.vel.x <- -rule2.vel.x 60 | rule2.vel.y <- -rule2.vel.y 61 | 62 | #print(rule2.vel.x) 63 | #print(rule2.vel.y) 64 | 65 | 66 | # normalize 67 | vnorm <- sqrt(rule2.vel.x*rule2.vel.x+rule2.vel.y*rule2.vel.y) 68 | rule2.vel.x <- rule2.vel.x / vnorm 69 | rule2.vel.y <- rule2.vel.y / vnorm 70 | 71 | nas <- is.na(rule2.vel.y) | is.na(rule2.vel.x) 72 | if (sum(nas) >0) { 73 | rule2.vel.x[nas] <- 0 74 | rule2.vel.y[nas] <- 0 75 | } 76 | 77 | # (3) cohesion 78 | center.x <- mean(x) 79 | center.y <- mean(y) 80 | rule3.vel.x <- -x+center.x 81 | rule3.vel.y <- -y+center.y 82 | # normalize 83 | vnorm <- sqrt(rule3.vel.x*rule3.vel.x+rule3.vel.y*rule3.vel.y) 84 | rule3.vel.x <- rule3.vel.x / vnorm 85 | rule3.vel.y <- rule3.vel.y / vnorm 86 | 87 | w1 <- 1 # alignment (2) 88 | w2 <- 1.5 # separation (.5) 89 | w3 <- 1 # cohesion (1) 90 | 91 | # add together velocities 92 | vel.x <- vel.x + w1*rule1.vel.x + w2*rule2.vel.x + w3*rule3.vel.x 93 | vel.y <- vel.y + w1*rule1.vel.y + w2*rule2.vel.y + w3*rule3.vel.y 94 | 95 | # normalize 96 | vnorm <- sqrt(vel.x*vel.x+vel.y*vel.y) 97 | vel.x <- vel.x / vnorm 98 | vel.y <- vel.y / vnorm 99 | 100 | # move 'em 101 | scale <- 0.05 102 | x <- x + vel.x*scale 103 | y <- y + vel.y*scale 104 | 105 | } 106 | 107 | } --------------------------------------------------------------------------------