Skip to content

@wch /server.r
Created

Embed URL

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Shiny example with rotating snakes illusion
library(grid)
shinyServer(function(input, output) {
output$main_plot <- renderPlot({
# Image parameters ---------------------------------------------------------
# Number of snakes in x and y directions
nx <- 3
ny <- 3
# Background colors
col_bg <- c("black", "white")
# Foreground colors
# Use HCL colors that we'll desaturate. The problem with HSV is that the
# luminance doesn't stay constant as the saturation changes.
col_fg <- c(hcl(250,
75 * input$saturation,
65 - 20 * (input$light_diff)),
hcl(70,
85 * input$saturation,
65 + 20 * input$light_diff))
# Render the image ---------------------------------------------------------
# Make snakes that rotate in different directions, by changing the position
# of the black and white background bars
snake_r <- snake(col_bg, col_fg)
snake_l <- snake(rev(col_bg), col_fg)
grid.newpage()
# Draw the bottom layer of snakes
for (i in 1:nx) {
for (j in 1:ny) {
pushViewport(viewport(x = i/nx, y = j/nx, width = 1/nx, height = 1/ny))
if ((i + j) %% 2 == 0)
grid.draw(snake_l)
else
grid.draw(snake_r)
popViewport()
}
}
# Draw the top layer of snakes
for (i in 1:(nx-1)) {
for (j in 1:(ny-1)) {
pushViewport(viewport(x = (i+0.5)/nx, y = (j+0.5)/nx, width = 1/nx, height = 1/ny))
if ((i + j) %% 2 == 0)
grid.draw(snake_l)
else
grid.draw(snake_r)
popViewport()
}
}
})
})
# ---------------------------------------------------------------------------
# Return a grob for a snake circle
snake <- function(col_bg, col_fg) {
nt <- 41
nr <- 15
br <- 0.8
r <- embed(br^(0:nr), 2)
t <- embed(seq(0, 2*pi, length=nt), 2)
i <- as.matrix(expand.grid(1:nrow(r), 1:nrow(t)))
ci <- 1 + (i[,2]%%2 + i[,1]%%2) %% 2
p <- t(apply(i, 1, function(x) c(r[x[1], ], t[x[2], ])))
x <- c(p[,1]*cos(p[,3]), p[,1]*cos(p[,4]), p[,2]*cos(p[,4]), p[,2]*cos(p[,3]))
y <- c(p[,1]*sin(p[,3]), p[,1]*sin(p[,4]), p[,2]*sin(p[,4]), p[,2]*sin(p[,3]))
background <- polygonGrob(x/2, y/2, id = rep.int(1:nrow(p), 4),
gp = gpar(fill = col_bg[ci], col=NA), default.units="native")
p <- expand.grid(1:nrow(r), -1 * seq(0, 2*pi, length=41)[-1])
p <- cbind(p[,2], rowMeans(r)[p[,1]], (r[,2]-r[,1])[p[,1]]/2)
t <- seq(0, 2*pi, length=20)[-1]
x <- c(apply(p, 1, function(a) a[2]*cos(a[1])+a[3]*(cos(a[1])*cos(t)-0.5*sin(a[1])*sin(t))))
y <- c(apply(p, 1, function(a) a[2]*sin(a[1])+a[3]*(sin(a[1])*cos(t)+0.5*cos(a[1])*sin(t))))
foreground <- polygonGrob(x/2, y/2, id = rep(1:nrow(p), each=length(t)),
gp = gpar(fill = col_fg[ci], col=NA), default.units="native")
grobTree(background, foreground)
}
shinyUI(pageWithSidebar(
headerPanel("Rotating snakes illusion"),
sidebarPanel(
sliderInput("saturation", "Color saturation",
min = 0, max = 1, value = 1, step = 0.1),
sliderInput("light_diff", "Difference in lightness",
min = 0, max = 1, value = 1, step = 0.1),
br(),
p("Illusion by ",
a("Akiyoshi KITAOKA", href="http://www.ritsumei.ac.jp/~akitaoka/index-e.html")
),
p("Based on R implementation by",
a("Kohske TAKAHASHI", href="http://www.fennel.rcast.u-tokyo.ac.jp/profilee_ktakahashi.html")
)
),
mainPanel(
plotOutput(outputId = "main_plot", width = "800px", height = "800px")
)
))
@geotheory

Nice work!

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Something went wrong with that request. Please try again.