Plot_ly rotate animation in R - r

I am trying to animate a 3D figure being rotated around an axis and print that as a .gif or video format. Could not find a resource to assist, please point me in the right direction. Any input is appreciated. Example figure below:
library(plotly)
x <- iris$Sepal.Length
y <- iris$Sepal.Width
z <- iris$Petal.Length
test3d <- plot_ly(type = "scatter3d", mode = "markers",
x=x, y=y, z=z)

This is taken from my earlier answer here.
We can use the code without shiny and save a standalone HTML file via htmlwidgets::saveWidget:
library(plotly)
library(htmlwidgets)
library(utils)
N <- 100
x <- rnorm(N, mean = 50, sd = 2.3)
y <- runif(N, min = 0, max = 100)
z <- runif(N, min = 4, max = 70)
luci.frame <- data.frame(x, y, z)
fig <- plot_ly(
type = "scatter3d",
mode = "markers",
data = luci.frame,
x = ~ x,
y = ~ y,
z = ~ z
) %>%
layout(scene = list(camera = list(
eye = list(
x = 1.25,
y = 1.25,
z = 1.25
),
center = list(x = 0,
y = 0,
z = 0)
))) %>%
onRender("
function(el, x){
var id = el.getAttribute('id');
var gd = document.getElementById(id);
Plotly.update(id).then(attach);
function attach() {
var cnt = 0;
function run() {
rotate('scene', Math.PI / 180);
requestAnimationFrame(run);
}
run();
function rotate(id, angle) {
var eye0 = gd.layout[id].camera.eye
var rtz = xyz2rtz(eye0);
rtz.t += angle;
var eye1 = rtz2xyz(rtz);
Plotly.relayout(gd, id + '.camera.eye', eye1)
}
function xyz2rtz(xyz) {
return {
r: Math.sqrt(xyz.x * xyz.x + xyz.y * xyz.y),
t: Math.atan2(xyz.y, xyz.x),
z: xyz.z
};
}
function rtz2xyz(rtz) {
return {
x: rtz.r * Math.cos(rtz.t),
y: rtz.r * Math.sin(rtz.t),
z: rtz.z
};
}
};
}
")
htmlwidgets::saveWidget(partial_bundle(fig), file = "rotate_scatter3d.HTML", selfcontained = TRUE)
utils::browseURL("rotate_scatter3d.HTML")

Related

I run the MCMC for SIR model code on my R software but there is no output until now

I tried to run code from https://cran.r-project.org/web/packages/MultiBD/vignettes/SIR-MCMC.pdf on my R software - they are still running but no output until now but I can run the following code on an online R compiler. This is the codes:
library(MultiBD)
data(Eyam)
Eyam
loglik_sir <- function(param, data) {
alpha <- exp(param[1]) # Rates must be non-negative
beta <- exp(param[2])
# Set-up SIR model
drates1 <- function(a, b) { 0 }
brates2 <- function(a, b) { 0 }
drates2 <- function(a, b) { alpha * b }
trans12 <- function(a, b) { beta * a * b }
sum(sapply(1:(nrow(data) - 1), # Sum across all time steps k
function(k) {
log(
dbd_prob( # Compute the transition probability matrix
t = data$time[k + 1] - data$time[k], # Time increment
a0 = data$S[k], b0 = data$I[k], # From: S(t_k), I(t_k)
drates1, brates2, drates2, trans12,
a = data$S[k + 1], B = data$S[k] + data$I[k] - data$S[k + 1],
computeMode = 4, nblocks = 80 # Compute using 4 threads
)[1, data$I[k + 1] + 1] # To: S(t_(k+1)), I(t_(k+1))
)
}))
}
logprior <- function(param) {
log_alpha <- param[1]
log_beta <- param[2]
dnorm(log_alpha, mean = 0, sd = 100, log = TRUE) +
dnorm(log_beta, mean = 0, sd = 100, log = TRUE)
}
library(MCMCpack)
alpha0 <- 3.39
beta0 <- 0.0212
post_sample <- MCMCmetrop1R(fun = function(param) { loglik_sir(param, Eyam) + logprior(param)
}, theta.init = log(c(alpha0, beta0)), mcmc = 500, burnin = 100)
plot(as.vector(post_sample[,1]), type = "l", xlab = "Iteration", ylab =
expression(log(alpha)))
plot(as.vector(post_sample[,2]), type = "l", xlab = "Iteration", ylab = expression(log(beta)))
library(ggplot2)
x = as.vector(post_sample[,1])
y = as.vector(post_sample[,2])
df <- data.frame(x, y)
ggplot(df,aes(x = x,y = y)) +
stat_density2d(aes(fill = ..level..), geom = "polygon", h = 0.26) +
scale_fill_gradient(low = "grey85", high = "grey35", guide = FALSE) +
xlab(expression(log(alpha))) +
ylab(expression(log(beta)))
quantile(exp(post_sample[,1]), probs = c(0.025,0.975))
quantile(exp(post_sample[,2]), probs = c(0.025,0.975))
I realize that this is the part of the codes that took long time to run but produce no output :
post_sample <- MCMCmetrop1R(fun = function(param) { loglik_sir(param, Eyam) + logprior(param)},
theta.init = log(c(alpha0, beta0)), mcmc = 500, burnin = 100)
I think my R software is the problem but what is it?

How to rotate 3D Plotly continuous for R shiny App

I am trying to create a constant rotating 3D scatter plotly so that I can put it in my R shiny app. However, I can't seem to get it to constantly rotate (like this: https://codepen.io/etpinard/pen/mBVVyE).
I don't want to save it to an image/gif just directly use in my App. Can anyone provide any help to get it continuously rotating (I have little experience with Python)? I've tried this in the Viewer screen of R studio, but it doesn't rotate there.
library(plotly)
library(ggplot2)
N <- 100
x <- rnorm(N, mean = 50, sd = 2.3)
y <- runif(N,min= 0, max = 100)
z <- runif(N, min = 4, max = 70)
luci.frame <- data.frame(x,y,z)
for (i in seq(0,100, by=0.1)){
cam.zoom = 2
ver.angle = 0
graph <- plot_ly()%>%
add_trace(type = "scatter3d",
mode = "markers",
data = luci.frame,
x = ~x,
y = ~y,
z = ~z) %>%
layout(scene = list(
camera = list(
eye = list(
x = cos(i)*cam.zoom,
y = sin(i)*cam.zoom,
z = 0.3
),
center = list(
x = 0,
y = 0,
z = 0
)
)
)
)
graph
}
I am very new to plotly, so any help would be greatly appreciated.
We can reuse most of the JS code via htmlwidgets::onRender. You tagged the question shiny - wrapped it in an app accordingly:
library(shiny)
library(plotly)
library(htmlwidgets)
ui <- fluidPage(
plotlyOutput("graph")
)
server <- function(input, output, session) {
N <- 100
x <- rnorm(N, mean = 50, sd = 2.3)
y <- runif(N, min = 0, max = 100)
z <- runif(N, min = 4, max = 70)
luci.frame <- data.frame(x, y, z)
output$graph <- renderPlotly({
plot_ly(
type = "scatter3d",
mode = "markers",
data = luci.frame,
x = ~ x,
y = ~ y,
z = ~ z
) %>%
layout(scene = list(camera = list(
eye = list(
x = 1.25,
y = 1.25,
z = 1.25
),
center = list(x = 0,
y = 0,
z = 0)
))) %>%
onRender("
function(el, x){
var id = el.getAttribute('id');
var gd = document.getElementById(id);
Plotly.update(id).then(attach);
function attach() {
var cnt = 0;
function run() {
rotate('scene', Math.PI / 180);
requestAnimationFrame(run);
}
run();
function rotate(id, angle) {
var eye0 = gd.layout[id].camera.eye
var rtz = xyz2rtz(eye0);
rtz.t += angle;
var eye1 = rtz2xyz(rtz);
Plotly.relayout(gd, id + '.camera.eye', eye1)
}
function xyz2rtz(xyz) {
return {
r: Math.sqrt(xyz.x * xyz.x + xyz.y * xyz.y),
t: Math.atan2(xyz.y, xyz.x),
z: xyz.z
};
}
function rtz2xyz(rtz) {
return {
x: rtz.r * Math.cos(rtz.t),
y: rtz.r * Math.sin(rtz.t),
z: rtz.z
};
}
};
}
")
})
}
shinyApp(ui, server)
The same can be done via plotlyProxy without additional JS - but it's not as smooth:
library(shiny)
library(plotly)
ui <- fluidPage(
plotlyOutput("graph")
)
server <- function(input, output, session) {
N <- 100
x <- rnorm(N, mean = 50, sd = 2.3)
y <- runif(N, min = 0, max = 100)
z <- runif(N, min = 4, max = 70)
luci.frame <- data.frame(x, y, z)
mySequence <- seq(0, 100, by = 0.1)
cam.zoom = 2
# ver.angle = 0
output$graph <- renderPlotly({
plot_ly(
type = "scatter3d",
mode = "markers",
data = luci.frame,
x = ~ x,
y = ~ y,
z = ~ z
) %>%
layout(scene = list(camera = list(
eye = list(
x = cos(mySequence[1]) * cam.zoom,
y = sin(mySequence[1]) * cam.zoom,
z = 0.3
),
center = list(x = 0,
y = 0,
z = 0)
)))
})
myPlotlyProxy <- plotlyProxy("graph")
count <- reactiveVal(1L)
observe({
invalidateLater(100)
plotlyProxyInvoke(myPlotlyProxy, "relayout", list(scene = list(camera = list(
eye = list(
x = cos(mySequence[isolate(count())]) * cam.zoom,
y = sin(mySequence[isolate(count())]) * cam.zoom,
z = 0.3
),
center = list(x = 0,
y = 0,
z = 0)
))))
isolate(count(count()+1))
if(count() > length(mySequence)){
count(1L)
}
})
}
shinyApp(ui, server)

How to set showing space in plotly

Is there any way to set the view and axes so that in my plotly animated 3D graph I can see a specific space and in this space the graph is moving? I'm trying to do an animation which shows how a detector works but right now when i play my animation the view and axes change along with the graph. I know that I can change the range of the axis but somehow it didn't change anything in my output or maybe i was doing something wrong.
Here is my code:
library(plotly)
Sx <- matrix()
Sy <- matrix()
Sz <- matrix()
N <- 360
u = seq(0, pi/2, length.out = 30)
w = seq(0, 2*pi, length.out = N)
datalist = list()
for (i in 1:N) {
Sx = cos(u) * cos(w[i])
Sy = cos(u) * sin(w[i])
Sz = sin(u)
df <- data.frame(Sx, Sy, Sz, t=i)
datalist[[i]] <- df
}
data = do.call(rbind, datalist)
plot_ly(data, x=~Sx, y =~Sy, z=~Sz, frame=~t, type = 'scatter3d', mode = 'lines')
Welcome to stackoverflow!
I'm not sure if I correctly understand your question. However, I think you are looking for a combination of range and aspectratio.
Please check the following:
library(plotly)
Sx <- matrix()
Sy <- matrix()
Sz <- matrix()
N <- 360
u = seq(0, pi/2, length.out = 30)
w = seq(0, 2*pi, length.out = N)
datalist = list()
for (i in 1:N) {
Sx = cos(u) * cos(w[i])
Sy = cos(u) * sin(w[i])
Sz = sin(u)
df <- data.frame(Sx, Sy, Sz, t=i)
datalist[[i]] <- df
}
data = do.call(rbind, datalist)
plot_ly(data, x=~Sx, y =~Sy, z=~Sz, frame=~t, type = 'scatter3d', mode = 'lines') %>%
layout(scene = list(xaxis = list(nticks = 5, range = c(-1, 1)),
yaxis = list(nticks = 5, range = c(-1, 1)),
zaxis = list(nticks = 5, range = c(-1, 1)),
aspectmode='manual',
aspectratio = list(x=1, y=1, z=1)
)) %>% animation_opts(frame = 100)
For further informarion please see this.

lasso/doodler tool for selecting points/drawing inside a plot

Sometimes I would like to use a mouse to draw a circle or squiggly shape around my plotted points to select these points specifically. Has anyone built functionality to do this yet? Perhaps something requiring Tcl/tk?
You could take advantage of locator, and then use the coordinates to put into a circle drawing function like from plotrix. Then put it into a function for ease of use:
plot(rnorm(100))
click.shape('circle', border = 'red', col = NA)
click.shape <- function(shape = c('circle', 'arrow', 'rect', 'cyl', 'line', 'poly'),
corners = 3L, ...) {
shape <- match.arg(shape)
coords <- if (shape %in% 'poly')
locator(as.integer(corners)) else unlist(locator(2L))
ARROW <- function(...) {
arrows(coords[1L], coords[3L], coords[2L], coords[4L], ...)
}
CIRCLE <- function(...) {
require(plotrix)
rad <- sqrt(((coords[2L] - coords[1L]) ^ 2) + ((coords[4L] - coords[3L]) ^ 2))
draw.circle(coords[1L], coords[3L], radius = rad, ...)
}
CYL <- function(...) {
require(plotrix)
cylindrect(coords[1L], coords[3L], coords[2L], coords[4L], ...)
}
LINE <- function(...) {
segments(coords[1L], coords[3L], coords[2L], coords[4L], ...)
}
POLY <- function(...) {
polygon(coords, ...)
}
RECT <- function(...) {
rect(coords[1L], coords[3L], coords[2L], coords[4L], ...)
}
suppressWarnings(
switch(shape, arrow = ARROW(...), circle = CIRCLE(...), cyl = CYL(...),
line = LINE(...), poly = POLY(...), rect = RECT(...),
stop('Invalid shape'))
)
}
Another option which I haven't had time lately to expand
set.seed(1618)
x <- runif(10)
y <- rnorm(10, mean = 5)
par(mfrow = c(1, 2))
plot(x, y, xlab = 'mean', ylab = 'sd')
zoomin(x, y)
## ESC to quit
code for zoomin
zoomin <- function(x, y, ...) {
op <- par(no.readonly = TRUE)
on.exit(par(op))
ans <- identify(x, y, n = 1, plot = FALSE, ...)
zoom <- function (x, y, xlim, ylim, xd, yd) {
rxlim <- x + c(-1, 1) * (diff(range(xd)) / 20)
rylim <- y + c(-1, 1) * (diff(range(yd)) / 20)
par(mfrow = c(1, 2))
plot(xd, yd, xlab = 'mean', ylab = 'sd')
xext <- yext <- rxext <- ryext <- 0
if (par('xaxs') == 'r') {
xext <- diff(xlim) * 0.04
rxext <- diff(rxlim) * 0.04
}
if (par('yaxs') == 'r') {
yext <- diff(ylim) * 0.04
ryext <- diff(rylim) * 0.04
}
rect(rxlim[1] - rxext, rylim[1] - ryext, rxlim[2] + rxext, rylim[2] + ryext)
xylim <- par('usr')
xypin <- par('pin')
rxi0 <- xypin[1] * (xylim[2] - (rxlim[1] - rxext)) / diff(xylim[1:2])
rxi1 <- xypin[1] * (xylim[2] - (rxlim[2] + rxext)) / diff(xylim[1:2])
y01i <- xypin[2] * (xylim[4] - (rylim[2] + ryext)) / diff(xylim[3:4])
y02i <- xypin[2] * ((rylim[1] - ryext) - xylim[3]) / diff(xylim[3:4])
mu <- x
curve(dnorm(x, mean = mu, sd = y), from = -4 * y + mu, to = 4 * y + mu,
xlab = paste('mean:', round(mu, 2), ', sd: ', round(y, 2)), ylab = '')
xypin <- par('pin')
par(xpd = NA)
xylim <- par('usr')
xymai <- par('mai')
x0 <- xylim[1] - diff(xylim[1:2]) * (xymai[2] + xymai[4] + rxi0)/xypin[1]
x1 <- xylim[1] - diff(xylim[1:2]) * (xymai[2] + xymai[4] + rxi1)/xypin[1]
y01 <- xylim[4] - diff(xylim[3:4]) * y01i/xypin[2]
y02 <- xylim[3] + diff(xylim[3:4]) * y02i/xypin[2]
par(xpd = TRUE)
xend <- xylim[1] - diff(xylim[1:2]) * xymai[2] / (2 * xypin[1])
xprop0 <- (xylim[1] - xend) / (xylim[1] - x0)
xprop1 <- (xylim[2] - xend) / (xylim[2] - x1)
par(xpd = NA)
segments(c(x0, x0, x1, x1),
c(y01, y02, y01, y02),
c(xend, xend, xend, xend),
c(xylim[4] - (xylim[4] - y01) * xprop0,
xylim[3] + (y02 - xylim[3]) * xprop0,
xylim[4] - (xylim[4] - y01) * xprop1,
xylim[3] + (y02 - xylim[3]) * xprop1))
par(mfg = c(1, 1))
plot(xd, yd, xlab = 'mean', ylab = 'sd')
}
if(length(ans)) {
zoom(x[ans], y[ans], range(x), range(y), x, y)
points(x[ans], y[ans], pch = 19)
zoomin(x, y)
}
}

Removing default title from wind rose in 'openair' package

I have created a wind rose using the package 'openair', for water current and direction data.
However, a default title is applied to the plot "Frequency of counts by wind direction (%)" which is not applicable to water current data. I cannot remove the title - can anyone help?
windRose(Wind, ws = "ws", wd = "wd", ws2 = NA, wd2 =NA,
ws.int = 20, angle = 10, type = "default", cols ="increment",
grid.line = NULL, width = 0.5, seg = NULL,
auto.text = TRUE, breaks = 5, offset = 10, paddle =FALSE,
key.header = "Current Speed", key.footer = "(cm/s)",
key.position = "right", key = TRUE, dig.lab = 3,
statistic = "prop.count", pollutant = NULL, annotate =
TRUE, border = NA, na.action=NULL)
Thanks!
There is another way that does not involve copying the whole function.
If you inspect the windRose code you can see that the title is set according to the value of the statistic option. In the documentation you can see that the oficial options are "prop.count", "prop.mean", "abs.count" and "frequency"; but code also checks if the argument passed to the statistic option is a list and sets the statistic options according to the list contents:
if (is.list(statistic)) {
stat.fun <- statistic$fun
stat.unit <- statistic$unit
stat.scale <- statistic$scale
stat.lab <- statistic$lab
stat.fun2 <- statistic$fun2
stat.lab2 <- statistic$lab2
stat.labcalm <- statistic$labcalm
}
the title that you want to change is defined by statistic$lab
By passing a list to the statistic option you can set among others, the title. So, an easy way to change the title is to pass a list to the statistic option with everything copied from one of the oficial options and changing the title. For example, let's say that I want to use "prop.count" with a custom title. Then I'd transform the options listed in the code:
stat.fun <- length
stat.unit <- "%"
stat.scale <- "all"
stat.lab <- "Frequency of counts by wind direction (%)"
stat.fun2 <- function(x) signif(mean(x, na.rm = TRUE),
3)
stat.lab2 <- "mean"
stat.labcalm <- function(x) round(x, 1)
into a named list with the title (lab) changed:
my.statistic <- list("fun"=length,"unit" = "%","scale" = "all", "lab" = "My title" , "fun2" = function(x) signif(mean(x, na.rm = TRUE), 3), "lab2" = "mean","labcalm" = function(x) round(x, 1))
and use it in the call to windRose:
windRose(mydata,statistic=my.statistic)
The great thing about a lot of R functions is you can type their name to see the source, in many cases. So here you could type windRose, and edit the required label as below:
windRose.2 <- function (mydata, ws = "ws", wd = "wd", ws2 = NA, wd2 = NA, ws.int = 2,
angle = 30, type = "default", cols = "default", grid.line = NULL,
width = 1, seg = NULL, auto.text = TRUE, breaks = 4, offset = 10,
paddle = TRUE, key.header = NULL, key.footer = "(m/s)", key.position = "bottom",
key = TRUE, dig.lab = 5, statistic = "prop.count", pollutant = NULL,
annotate = TRUE, border = NA, ...)
{
if (is.null(seg))
seg <- 0.9
if (length(cols) == 1 && cols == "greyscale") {
trellis.par.set(list(strip.background = list(col = "white")))
calm.col <- "black"
}
else {
calm.col <- "forestgreen"
}
current.strip <- trellis.par.get("strip.background")
on.exit(trellis.par.set("strip.background", current.strip))
if (360/angle != round(360/angle)) {
warning("In windRose(...):\n angle will produce some spoke overlap",
"\n suggest one of: 5, 6, 8, 9, 10, 12, 15, 30, 45, etc.",
call. = FALSE)
}
if (angle < 3) {
warning("In windRose(...):\n angle too small", "\n enforcing 'angle = 3'",
call. = FALSE)
angle <- 3
}
extra.args <- list(...)
extra.args$xlab <- if ("xlab" %in% names(extra.args))
quickText(extra.args$xlab, auto.text)
else quickText("", auto.text)
extra.args$ylab <- if ("ylab" %in% names(extra.args))
quickText(extra.args$ylab, auto.text)
else quickText("", auto.text)
extra.args$main <- if ("main" %in% names(extra.args))
quickText(extra.args$main, auto.text)
else quickText("", auto.text)
if (is.character(statistic)) {
ok.stat <- c("prop.count", "prop.mean", "abs.count",
"frequency")
if (!is.character(statistic) || !statistic[1] %in% ok.stat) {
warning("In windRose(...):\n statistic unrecognised",
"\n enforcing statistic = 'prop.count'", call. = FALSE)
statistic <- "prop.count"
}
if (statistic == "prop.count") {
stat.fun <- length
stat.unit <- "%"
stat.scale <- "all"
stat.lab <- ""
stat.fun2 <- function(x) signif(mean(x, na.rm = TRUE),
3)
stat.lab2 <- "mean"
stat.labcalm <- function(x) round(x, 1)
}
if (statistic == "prop.mean") {
stat.fun <- function(x) sum(x, na.rm = TRUE)
stat.unit <- "%"
stat.scale <- "panel"
stat.lab <- "Proportion contribution to the mean (%)"
stat.fun2 <- function(x) signif(mean(x, na.rm = TRUE),
3)
stat.lab2 <- "mean"
stat.labcalm <- function(x) round(x, 1)
}
if (statistic == "abs.count" | statistic == "frequency") {
stat.fun <- length
stat.unit <- ""
stat.scale <- "none"
stat.lab <- "Count by wind direction"
stat.fun2 <- function(x) round(length(x), 0)
stat.lab2 <- "count"
stat.labcalm <- function(x) round(x, 0)
}
}
if (is.list(statistic)) {
stat.fun <- statistic$fun
stat.unit <- statistic$unit
stat.scale <- statistic$scale
stat.lab <- statistic$lab
stat.fun2 <- statistic$fun2
stat.lab2 <- statistic$lab2
stat.labcalm <- statistic$labcalm
}
vars <- c(wd, ws)
diff <- FALSE
rm.neg <- TRUE
if (!is.na(ws2) & !is.na(wd2)) {
vars <- c(vars, ws2, wd2)
diff <- TRUE
rm.neg <- FALSE
mydata$ws <- mydata[, ws2] - mydata[, ws]
mydata$wd <- mydata[, wd2] - mydata[, wd]
id <- which(mydata$wd < 0)
if (length(id) > 0)
mydata$wd[id] <- mydata$wd[id] + 360
pollutant <- "ws"
key.footer <- "ws"
wd <- "wd"
ws <- "ws"
vars <- c("ws", "wd")
if (missing(angle))
angle <- 10
if (missing(offset))
offset <- 20
if (is.na(breaks[1])) {
max.br <- max(ceiling(abs(c(min(mydata$ws, na.rm = TRUE),
max(mydata$ws, na.rm = TRUE)))))
breaks <- c(-1 * max.br, 0, max.br)
}
if (missing(cols))
cols <- c("lightskyblue", "tomato")
seg <- 1
}
if (any(type %in% openair:::dateTypes))
vars <- c(vars, "date")
if (!is.null(pollutant))
vars <- c(vars, pollutant)
mydata <- openair:::checkPrep(mydata, vars, type, remove.calm = FALSE,
remove.neg = rm.neg)
mydata <- na.omit(mydata)
if (is.null(pollutant))
pollutant <- ws
mydata$x <- mydata[, pollutant]
mydata[, wd] <- angle * ceiling(mydata[, wd]/angle - 0.5)
mydata[, wd][mydata[, wd] == 0] <- 360
mydata[, wd][mydata[, ws] == 0] <- -999
if (length(breaks) == 1)
breaks <- 0:(breaks - 1) * ws.int
if (max(breaks) < max(mydata$x, na.rm = TRUE))
breaks <- c(breaks, max(mydata$x, na.rm = TRUE))
if (min(breaks) > min(mydata$x, na.rm = TRUE))
warning("Some values are below minimum break.")
breaks <- unique(breaks)
mydata$x <- cut(mydata$x, breaks = breaks, include.lowest = FALSE,
dig.lab = dig.lab)
theLabels <- gsub("[(]|[)]|[[]|[]]", "", levels(mydata$x))
theLabels <- gsub("[,]", " to ", theLabels)
prepare.grid <- function(mydata) {
if (all(is.na(mydata$x)))
return()
levels(mydata$x) <- c(paste("x", 1:length(theLabels),
sep = ""))
all <- stat.fun(mydata[, wd])
calm <- mydata[mydata[, wd] == -999, ][, pollutant]
mydata <- mydata[mydata[, wd] != -999, ]
calm <- stat.fun(calm)
weights <- tapply(mydata[, pollutant], list(mydata[,
wd], mydata$x), stat.fun)
if (stat.scale == "all") {
calm <- calm/all
weights <- weights/all
}
if (stat.scale == "panel") {
temp <- stat.fun(stat.fun(weights)) + calm
calm <- calm/temp
weights <- weights/temp
}
weights[is.na(weights)] <- 0
weights <- t(apply(weights, 1, cumsum))
if (stat.scale == "all" | stat.scale == "panel") {
weights <- weights * 100
calm <- calm * 100
}
panel.fun <- stat.fun2(mydata[, pollutant])
u <- mean(sin(2 * pi * mydata[, wd]/360))
v <- mean(cos(2 * pi * mydata[, wd]/360))
mean.wd <- atan2(u, v) * 360/2/pi
if (all(is.na(mean.wd))) {
mean.wd <- NA
}
else {
if (mean.wd < 0)
mean.wd <- mean.wd + 360
if (mean.wd > 180)
mean.wd <- mean.wd - 360
}
weights <- cbind(data.frame(weights), wd = as.numeric(row.names(weights)),
calm = calm, panel.fun = panel.fun, mean.wd = mean.wd)
weights
}
if (paddle) {
poly <- function(wd, len1, len2, width, colour, x.off = 0,
y.off = 0) {
theta <- wd * pi/180
len1 <- len1 + off.set
len2 <- len2 + off.set
x1 <- len1 * sin(theta) - width * cos(theta) + x.off
x2 <- len1 * sin(theta) + width * cos(theta) + x.off
x3 <- len2 * sin(theta) - width * cos(theta) + x.off
x4 <- len2 * sin(theta) + width * cos(theta) + x.off
y1 <- len1 * cos(theta) + width * sin(theta) + y.off
y2 <- len1 * cos(theta) - width * sin(theta) + y.off
y3 <- len2 * cos(theta) + width * sin(theta) + y.off
y4 <- len2 * cos(theta) - width * sin(theta) + y.off
lpolygon(c(x1, x2, x4, x3), c(y1, y2, y4, y3), col = colour,
border = border)
}
}
else {
poly <- function(wd, len1, len2, width, colour, x.off = 0,
y.off = 0) {
len1 <- len1 + off.set
len2 <- len2 + off.set
theta <- seq((wd - seg * angle/2), (wd + seg * angle/2),
length.out = (angle - 2) * 10)
theta <- ifelse(theta < 1, 360 - theta, theta)
theta <- theta * pi/180
x1 <- len1 * sin(theta) + x.off
x2 <- rev(len2 * sin(theta) + x.off)
y1 <- len1 * cos(theta) + x.off
y2 <- rev(len2 * cos(theta) + x.off)
lpolygon(c(x1, x2), c(y1, y2), col = colour, border = border)
}
}
mydata <- cutData(mydata, type, ...)
results.grid <- ddply(mydata, type, prepare.grid)
results.grid$calm <- stat.labcalm(results.grid$calm)
results.grid$mean.wd <- stat.labcalm(results.grid$mean.wd)
strip.dat <- openair:::strip.fun(results.grid, type, auto.text)
strip <- strip.dat[[1]]
strip.left <- strip.dat[[2]]
pol.name <- strip.dat[[3]]
if (length(theLabels) < length(cols)) {
col <- cols[1:length(theLabels)]
}
else {
col <- openColours(cols, length(theLabels))
}
max.freq <- max(results.grid[, (length(type) + 1):(length(theLabels) +
length(type))], na.rm = TRUE)
off.set <- max.freq * (offset/100)
box.widths <- seq(0.002^0.25, 0.016^0.25, length.out = length(theLabels))^4
box.widths <- box.widths * max.freq * angle/5
legend <- list(col = col, space = key.position, auto.text = auto.text,
labels = theLabels, footer = key.footer, header = key.header,
height = 0.6, width = 1.5, fit = "scale", plot.style = if (paddle) "paddle" else "other")
legend <- openair:::makeOpenKeyLegend(key, legend, "windRose")
temp <- paste(type, collapse = "+")
myform <- formula(paste("x1 ~ wd | ", temp, sep = ""))
mymax <- 2 * max.freq
myby <- if (is.null(grid.line))
pretty(c(0, mymax), 10)[2]
else grid.line
if (myby/mymax > 0.9)
myby <- mymax * 0.9
xyplot.args <- list(x = myform, xlim = 1.03 * c(-max.freq -
off.set, max.freq + off.set), ylim = 1.03 * c(-max.freq -
off.set, max.freq + off.set), data = results.grid, type = "n",
sub = stat.lab, strip = strip, strip.left = strip.left,
as.table = TRUE, aspect = 1, par.strip.text = list(cex = 0.8),
scales = list(draw = FALSE), panel = function(x, y, subscripts,
...) {
panel.xyplot(x, y, ...)
angles <- seq(0, 2 * pi, length = 360)
sapply(seq(off.set, mymax, by = myby), function(x) llines(x *
sin(angles), x * cos(angles), col = "grey85",
lwd = 1))
subdata <- results.grid[subscripts, ]
upper <- max.freq + off.set
larrows(-upper, 0, upper, 0, code = 3, length = 0.1)
larrows(0, -upper, 0, upper, code = 3, length = 0.1)
ltext(upper * -1 * 0.95, 0.07 * upper, "W", cex = 0.7)
ltext(0.07 * upper, upper * -1 * 0.95, "S", cex = 0.7)
ltext(0.07 * upper, upper * 0.95, "N", cex = 0.7)
ltext(upper * 0.95, 0.07 * upper, "E", cex = 0.7)
if (nrow(subdata) > 0) {
for (i in 1:nrow(subdata)) {
with(subdata, {
for (j in 1:length(theLabels)) {
if (j == 1) {
temp <- "poly(wd[i], 0, x1[i], width * box.widths[1], col[1])"
} else {
temp <- paste("poly(wd[i], x", j - 1,
"[i], x", j, "[i], width * box.widths[",
j, "], col[", j, "])", sep = "")
}
eval(parse(text = temp))
}
})
}
}
ltext(seq((myby + off.set), mymax, myby) * sin(pi/4),
seq((myby + off.set), mymax, myby) * cos(pi/4),
paste(seq(myby, mymax, by = myby), stat.unit,
sep = ""), cex = 0.7)
if (annotate) if (statistic != "prop.mean") {
if (!diff) {
ltext(max.freq + off.set, -max.freq - off.set,
label = paste(stat.lab2, " = ", subdata$panel.fun[1],
"\ncalm = ", subdata$calm[1], stat.unit,
sep = ""), adj = c(1, 0), cex = 0.7, col = calm.col)
}
if (diff) {
ltext(max.freq + off.set, -max.freq - off.set,
label = paste("mean ws = ", round(subdata$panel.fun[1],
1), "\nmean wd = ", round(subdata$mean.wd[1],
1), sep = ""), adj = c(1, 0), cex = 0.7,
col = calm.col)
}
} else {
ltext(max.freq + off.set, -max.freq - off.set,
label = paste(stat.lab2, " = ", subdata$panel.fun[1],
stat.unit, sep = ""), adj = c(1, 0), cex = 0.7,
col = calm.col)
}
}, legend = legend)
xyplot.args <- openair:::listUpdate(xyplot.args, extra.args)
plt <- do.call(xyplot, xyplot.args)
if (length(type) == 1)
plot(plt)
else plot(useOuterStrips(plt, strip = strip, strip.left = strip.left))
newdata <- results.grid
output <- list(plot = plt, data = newdata, call = match.call())
class(output) <- "openair"
invisible(output)
}
Here I've copied the entire source, and made a new function, windRose.2 with the only difference being stat.lab <- "Frequency of counts by wind direction (%)" is now stat.lab <- "".

Resources