How to set showing space in plotly - r

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.

Related

Drawing a partially transparent density polygon

How can I make this red polygon partially transparent so I can see the points underneath it?
library(ks)
set.seed(1234)
x <- runif(1000) + -150
y <- runif(1000) + 20
my.data <- data.frame(x,y)
my.matrix <- as.matrix(my.data)
my_gps_hpi <- Hpi(x = my.matrix, pilot = "samse", pre = "scale")
my.fhat <- kde(x = my.matrix, compute.cont = TRUE, h = my_gps_hpi,
xmin = c(min(my.data$x), min(my.data$y)),
xmax = c(max(my.data$x), max(my.data$y)),
bgridsize = c(100, 100))
my.contours <- c(75)
contourLevels(my.fhat, cont = my.contours)
contourSizes(my.fhat, cont = my.contours, approx = TRUE)
plot(my.data$x, my.data$y)
plot(my.fhat, lwd = 3, display = "filled.contour", cont = my.contours, add = TRUE)
png(file="transparent_polygon_June21_2021.png")
plot(my.data$x, my.data$y)
plot(my.fhat, lwd = 3, display = "filled.contour", cont = my.contours, add = TRUE)
dev.off()
I think I have figured out a solution by digging around in the source code in the file kde.R.
I made several changes to my code.
Changed my.fhat to fhat because the source code might want fhat.
Changed my.contours to contours for the same reason.
Changed contourLevels(my.fhat, cont = my.contours) to hts <- contourLevels(fhat, cont = contours) for the same reason.
Extracted the col.fun from the source code and changed it to return the color of my choice: col.fun <- function(n) {rgb(255, 0, 0, 127, maxColorValue=255)}.
Modified the plot statement to that shown in the code below.
Here is the modified R code:
setwd('C:/Users/mark_/Documents/ctmm/density_in_R/')
set.seed(1234)
library(ks)
x <- runif(1000) + -150
y <- runif(1000) + 20
my.data <- data.frame(x,y)
my.matrix <- as.matrix(my.data)
gps_hpi <- Hpi(x = my.matrix, pilot = "samse", pre = "scale")
fhat <- kde(x = my.matrix, compute.cont = TRUE, h = gps_hpi,
xmin = c(min(my.data$x), min(my.data$y)),
xmax = c(max(my.data$x), max(my.data$y)),
bgridsize = c(100, 100))
contours <- c(75)
hts <- contourLevels(fhat, cont = contours)
contourSizes(fhat, cont = contours, approx = TRUE)
col.fun <- function(n) {rgb(255, 0, 0, 127, maxColorValue=255)}
col.fun(1)
plot(fhat, lwd = 3, display = "filled.contour", cont = contours, col.fun = col.fun(1), drawpoints=TRUE)
png(file="transparent_polygon_June22_2021.png")
plot(fhat, lwd = 3, display = "filled.contour", cont = contours, col.fun = col.fun(1), drawpoints=TRUE)
dev.off()

Plot heatmaps of multiple data frames using a slider in R

I have multiple data.frames and each one of them represent the pairwise interactions of individuals at different time points.
Here is an example of how my data.frames look.
df1 <- matrix(data = rexp(9, rate = 10), nrow = 3, ncol = 3)
df2 <- matrix(data = rexp(16, rate = 10), nrow = 4, ncol = 4)
df3 <- matrix(data = rexp(4, rate = 10), nrow = 2, ncol = 2)
I would like to plot them as it is pointed in this page (https://plotly.com/r/sliders/)
where with a slider I can move from one heatmap to the other.
I have tried so far with plotly but I have not succeeded. Any help is highly appreciated.
I am struggling for long with this issue. I might be a bit blind at this point so please forgive me if the question is stupid.
Following the Sine Wave Slider example on https://plotly.com/r/sliders/ this can be achieved like so. The first step of my approach involves converting the matrices to dataframes with columns x, y, z. Second instead of lines we plot heatmaps.
df1 <- matrix(data = rexp(9, rate = 10), nrow = 3, ncol = 3)
df2 <- matrix(data = rexp(16, rate = 10), nrow = 4, ncol = 4)
df3 <- matrix(data = rexp(4, rate = 10), nrow = 2, ncol = 2)
library(tibble)
library(tidyr)
library(plotly)
# Make dataframes
d <- lapply(list(df1, df2, df3), function(d) {
d %>%
as_tibble(.colnames = seq(ncol(.))) %>%
rowid_to_column("x") %>%
pivot_longer(-x, names_to = "y", values_to = "z") %>%
mutate(y = stringr::str_extract(y, "\\d"),
y = as.numeric(y))
})
aval <- list()
for(step in seq_along(d)){
aval[[step]] <-list(visible = FALSE,
name = paste0('v = ', step),
x = d[[step]]$x,
y = d[[step]]$y,
z = d[[step]]$z)
}
aval[1][[1]]$visible = TRUE
steps <- list()
fig <- plot_ly()
for (i in seq_along(aval)) {
fig <- add_trace(fig, x = aval[i][[1]]$x, y = aval[i][[1]]$y, z = aval[i][[1]]$z, visible = aval[i][[1]]$visible,
name = aval[i][[1]]$name, type = "heatmap")
fig
step <- list(args = list('visible', rep(FALSE, length(aval))), method = 'restyle')
step$args[[2]][i] = TRUE
steps[[i]] = step
}
fig <- fig %>%
layout(sliders = list(list(active = 0,
currentvalue = list(prefix = "Heatmap: "),
steps = steps)))
fig

plotly - different colours for different surfaces

Using plotly I would like to have each surface to have different colour.
library(plotly)
t1 <- seq(-3, 3, 0.1); t2 <- seq(-3, 3, 0.1)
p1 <- matrix(nrow = length(t1), ncol = length(t2))
p2 <- matrix(nrow = length(t1), ncol = length(t2))
p8a1 <- 1.2
p8a2 <- 1
p8d <- -1
p8b1 <- 0.7
p8b2 <- 0.6
for (i in 1:length(t2)) {
for (j in 1:length(t1)) {
p1[i, j] <- 1 / (1 + exp(-1.7 * (p8a1 * t1[j] + p8a2 * t2[i] + p8d)))
p2[i, j] <- (1 / (1 + exp(-1.7 * p8a1 * (t1[j]- p8b1)))) *
(1 / (1 + exp(-1.7 * p8a2 * (t2[j]- p8b2))))
}
}
df1 <- list(t1, t2, p1)
df2 <- list(t1, t2, p2)
names(df1) <- c("t1", "t2", "p1")
names(df2) <- c("t1", "t2", "p2")
m <- list(l = 10, r = 10, b = 5, t = 0, pad = 3)
p <- plot_ly(color = c("red", "blue")) %>%
add_surface(x = df1$t1,
y = df1$t2,
z = df1$p1,
opacity = 0.8) %>%
add_surface(x = df2$t1,
y = df2$t2,
z = df2$p2,
opacity = 1) %>%
layout(autosize = F, width = 550, height = 550, margin = m,
scene = list(xaxis = list(title = "Theta 1"),
yaxis = list(title = "Theta 2"),
zaxis = list(title = "P")),
dragmode = "turntable")
p
Unfortunately, I'm not able to change colours of these two surfaces. I tried to add color = I("red") and color = I("blue") arguments into add_surface but this just changed colour scale from red to blue for both surfaces.
I also tried to add color = "red" into plot_ly() and add inherit = F into second add_surface. This changed the first surface only, but only the yellow default color into red. I would love to have one surface red and second one blue.
Sounds trivial but it's a bit tricky in Plotly. The color of a surface plot is either derived from the z values or from an array with the same dimensions as z. This color array only accepts numerical values, no color strings or RGB values.
So let's define an array for our colors
color <- rep(0, length(df1$p1))
dim(color) <- dim(df1$p1)
Next we need to trick Plotly into ignoring the colorscale.
surfacecolor=color,
cauto=F,
cmax=1,
cmin=0
et voilĂ , we have a uniformely colored plot.
library(plotly)
t1 <- seq(-3, 3, 0.1); t2 <- seq(-3, 3, 0.1)
p1 <- matrix(nrow = length(t1), ncol = length(t2))
p2 <- matrix(nrow = length(t1), ncol = length(t2))
p8a1 <- 1.2
p8a2 <- 1
p8d <- -1
p8b1 <- 0.7
p8b2 <- 0.6
for (i in 1:length(t2)) {
for (j in 1:length(t1)) {
p1[i, j] <- 1 / (1 + exp(-1.7 * (p8a1 * t1[j] + p8a2 * t2[i] + p8d)))
p2[i, j] <- (1 / (1 + exp(-1.7 * p8a1 * (t1[j]- p8b1)))) *
(1 / (1 + exp(-1.7 * p8a2 * (t2[j]- p8b2))))
}
}
df1 <- list(t1, t2, p1)
df2 <- list(t1, t2, p2)
names(df1) <- c("t1", "t2", "p1")
names(df2) <- c("t1", "t2", "p2")
m <- list(l = 10, r = 10, b = 5, t = 0, pad = 3)
color <- rep(0, length(df1$p1))
dim(color) <- dim(df1$p1)
p <- plot_ly(colors = c('red', 'blue')) %>%
add_surface(x = df1$t1,
y = df1$t2,
z = df1$p1,
opacity = 0.8,
#surfacecolor=c('red')
surfacecolor=color,
cauto=F,
cmax=1,
cmin=0
)
color2 <- rep(1, length(df2$p2))
dim(color2) <- dim(df2$p2 )
p <- add_surface(p,
x = df2$t1,
y = df2$t2,
z = df2$p2,
opacity = 1,
surfacecolor=color2,
cauto=F,
cmax=1,
cmin=0)
p

R Corrgram showing frequency pairs that have zero abundance 'Pie Method'

I am attempting to reproduce a corrgram (below; Fig 1) using Zuur et al (2010) reproducible R code (below) showing the frequency with which pairs of water- bird species both have zero abundance. The colour and the amount that a circle has been filled correspond to the proportion of observa- tions with double zeros. The diagonal running from bottom left to the top right represents the percentage of observations of a variable equal to zero..
I have adapted this code for my data but I am experiencing the same problem after running the code for both datasets. When I run the code, the circles inside the corrgram are not filling in, and remain empty (below; Figure 2).
I am however confused as to why I am hitting this problem. If anyone has a solution as to why this occurs, then I would be deeply appreciative for your help.
Data: By Zuur et al (2010)
The data is too large to include with this post but it can be found in the supporting materials section called ElphickBirdData.txt
R Code: Zuur et al (2010)
RiceField <- read.table(file="ElphickBirdData.txt", header = TRUE)
AllS <- c(
"TUSW", "GWFG", "WHGO", "CAGO", "MALL",
"GADW", "GWTE", "CITE", "UNTE", "AMWI", "NOPI",
"NOSH", "RIDU", "CANV", "BUFF", "WODU", "RUDU",
"EUWI", "UNDU", "PBGB", "SORA", "COOT", "COMO",
"AMBI", "BCNH", "GBHE", "SNEG", "GREG", "WFIB",
"SACR", "AMAV", "BNST", "BBPL", "KILL", "LBCU",
"GRYE", "LEYE", "LBDO", "SNIP", "DUNL", "WESA",
"LESA", "PEEP", "RUFF", "UNSH", "RBGU", "HEGU",
"CAGU", "GUSP")
#Determine species richness
Richness <- colSums(RiceField[,AllS] > 0, na.rm = TRUE)
#Remove all covariates
Birds <- RiceField[,AllS]
#To reduce the of variables in the figure, we only used the
#20 species that occured at more than 40 sites.
#As a result, N = 20. Else it becomes a mess.
Birds2 <- Birds[, Richness > 40]
N <- ncol(Birds2)
AllNames <- names(Birds2)
A <- matrix(nrow = N, ncol = N)
for (i in 1:N){
for (j in 1:N){
A[i,j] <- sum(RiceField[,AllS[i]]==0 & RiceField[,AllS[j]]==0, na.rm=TRUE)
}}
A1 <- A/2035
print(A1, digits = 2)
rownames(A1) <- AllNames
colnames(A1) <- AllNames
library(lattice)
library(RColorBrewer)
panel.corrgram.2 <- function(x, y, z, subscripts, at = pretty(z), scale = 0.8, ...)
{
require("grid", quietly = TRUE)
x <- as.numeric(x)[subscripts]
y <- as.numeric(y)[subscripts]
z <- as.numeric(z)[subscripts]
zcol <- level.colors(z, at = at, ...)
for (i in seq(along = z))
{
lims <- range(0, z[i])
tval <- 2 * base::pi *
seq(from = lims[1], to = lims[2], by = 0.01)
grid.polygon(x = x[i] + .5 * scale * c(0, sin(tval)),
y = y[i] + .5 * scale * c(0, cos(tval)),
default.units = "native",
gp = gpar(fill = zcol[i]))
grid.circle(x = x[i], y = y[i], r = .5 * scale,
default.units = "native")
}
}
levelplot(A1,xlab=NULL,ylab=NULL,
at=do.breaks(c(0.5,1.01),101),
panel=panel.corrgram.2,
scales=list(x=list(rot=90)),
colorkey=list(space="top"),
col.regions=colorRampPalette(c("red","white","blue")))
#Grey colours
levelplot(A1.bats,xlab=NULL,ylab=NULL,
at=do.breaks(c(0.5,1.01),101),
panel=panel.corrgram.2,
scales=list(x=list(rot=90)),
colorkey=list(space="top"),
col.regions=colorRampPalette(c(grey(0.8),grey(0.5),grey(0.2))))
Figure 1.
Figure 2
The cause of your problem is that grid.circles daubs grid.polygon with white. You can solved it by changing order of grid.circle and grid.polygon (or add gp = gpar(fill=NA) to grid.circle() ).
panel.corrgram.2.2 <- function(x, y, z, subscripts, at = pretty(z), scale = 0.8, ...)
{
require("grid", quietly = TRUE)
x <- as.numeric(x)[subscripts]
y <- as.numeric(y)[subscripts]
z <- as.numeric(z)[subscripts]
zcol <- level.colors(z, at = at, ...)
for (i in seq(along = z))
{
lims <- range(0, z[i])
tval <- 2 * base::pi *
seq(from = lims[1], to = lims[2], by = 0.01)
grid.circle(x = x[i], y = y[i], r = .5 * scale, # change the order
default.units = "native")
grid.polygon(x = x[i] + .5 * scale * c(0, sin(tval)),
y = y[i] + .5 * scale * c(0, cos(tval)),
default.units = "native",
gp = gpar(fill = zcol[i]))
}
}
levelplot(A1,xlab=NULL,ylab=NULL,
at=do.breaks(c(0.5,1.01),101),
panel=panel.corrgram.2.2,
scales=list(x=list(rot=90)),
colorkey=list(space="top"),
col.regions=colorRampPalette(c("red","white","blue")))

Graphical output of density for the function gammamixEM (package mixtools)

I'm using the function gammamixEM from the package mixtools. How can I return the graphical output of density as in the function normalmixEM (i.e., the second plot in plot(...,which=2)) ?
Update:
Here is a reproducible example for the function gammamixEM:
x <- c(rgamma(200, shape = 0.2, scale = 14), rgamma(200,
shape = 32, scale = 10), rgamma(200, shape = 5, scale = 6))
out <- gammamixEM(x, lambda = c(1, 1, 1)/3, verb = TRUE)
Here is a reproducible example for the function normalmixEM:
data(faithful)
attach(faithful)
out <- normalmixEM(waiting, arbvar = FALSE, epsilon = 1e-03)
plot(out, which=2)
I would like to obtain this graphical output of density from the function gammamixEM.
Here you go.
out <- normalmixEM(waiting, arbvar = FALSE, epsilon = 1e-03)
x <- out
whichplots <- 2
density = 2 %in% whichplots
loglik = 1 %in% whichplots
def.par <- par(ask=(loglik + density > 1), "mar") # only ask and mar are changed
mix.object <- x
k <- ncol(mix.object$posterior)
x <- sort(mix.object$x)
a <- hist(x, plot = FALSE)
maxy <- max(max(a$density), .3989*mix.object$lambda/mix.object$sigma)
I just had to dig into the source code of plot.mixEM
So, now to do this with gammamixEM:
x <- c(rgamma(200, shape = 0.2, scale = 14), rgamma(200,
shape = 32, scale = 10), rgamma(200, shape = 5, scale = 6))
gammamixEM.out <- gammamixEM(x, lambda = c(1, 1, 1)/3, verb = TRUE)
mix.object <- gammamixEM.out
k <- ncol(mix.object$posterior)
x <- sort(mix.object$x)
a <- hist(x, plot = FALSE)
maxy <- max(max(a$density), .3989*mix.object$lambda/mix.object$sigma)
main2 <- "Density Curves"
xlab2 <- "Data"
col2 <- 2:(k+1)
hist(x, prob = TRUE, main = main2, xlab = xlab2,
ylim = c(0,maxy))
for (i in 1:k) {
lines(x, mix.object$lambda[i] *
dnorm(x,
sd = sd(x)))
}
I believe it should be pretty straight forward to continue this example a bit, if you want to add the labels, smooth lines, etc. Here's the source of the plot.mixEM function.

Resources