Axes resetting when combining plotly animations in shiny using plotlyProxyInvoke - r

I am trying to make an animated plot where new traces are introduced, the traces are animated, and the axes are then rescaled. I am having trouble getting these things to work together. A reprex is below. It works except when I have both Animate Traces and Rescale Axis, then the axis rescaling gets reset on every iteration.
Using Proxy Interface in Plotly/Shiny to dynamically change data
https://community.plot.ly/t/how-to-efficiently-restyle-update-modify-plot-containing-frames/5553
https://plot.ly/javascript/plotlyjs-function-reference/
https://plot.ly/javascript/animations/
It's rather hard to follow the Plotly documentation. I couldn't get addFrames, relayout, restyle, react, or update to work for me. I've had the most luck with animate. I would greatly appreciate any help, I've been struggling with this for two weeks already.
# plotly_add_anim13.R
library(shiny)
library(plotly)
library(dplyr)
library(purrr)
ui <- fluidPage(
checkboxInput("add", "Add Trace", TRUE),
checkboxInput("animate", "Animate Traces", FALSE),
checkboxInput("rescale", "Rescale Axis", FALSE),
plotlyOutput("plot")
)
server <- function(input, output, session){
my <- reactiveValues(
fnumber = NA, # frame number
frame = NA, # frame data list
ntraces = NA, # number of traces
xrange = NA # xaxis range
)
speed = 1000 # redraw interval in milliseconds
output$plot <- renderPlotly({
isolate({
cat("renderPlotly\n")
my$fnumber <- 1
my$ntraces <- 2
f <- as.character(my$fnumber)
x <- runif(2)
y <- rep(runif(1), 2)
t <- c("A", "B")
ids0 <- paste0(my$ntraces-2, letters[1:2])
ids1 <- paste0(my$ntraces-1, letters[1:2])
my$xrange <- c(0,1)
# https://community.plot.ly/t/how-to-efficiently-restyle-update-modify-plot-containing-frames/5553
my$frame <- list(
name = f,
data = list(
list(x=x, y=y, frame=f, ids=ids0, type="scatter", mode="lines", showlegend=FALSE),
list(x=x, y=y, frame=f, ids=ids1, type="scatter", mode="text", text=t, showlegend=FALSE)
),
traces = as.list(as.integer(c(my$ntraces-2, my$ntraces-1))),
layout = list(xaxis=list(range=my$xrange, zeroline=FALSE),
yaxis=list(range=c(0,1), tickmode="array", tickvals=seq(0,1,0.2), ticktext=seq(0,1,0.2)))
)
p <- plot_ly()
p <- do.call(add_trace, prepend(my$frame$data[[1]], list(p)))
p <- do.call(add_trace, prepend(my$frame$data[[2]], list(p)))
p <- do.call(layout, prepend(my$frame$layout, list(p)))
p <- animation_opts(p, frame=speed, transition=speed)
p
})
})
proxy <- plotlyProxy("plot", session=session)
# https://shiny.rstudio.com/reference/shiny/0.14/reactiveTimer.html
autoInvalidate <- reactiveTimer(speed*2)
observeEvent(autoInvalidate(), {
# req(NULL)
# https://stackoverflow.com/questions/50620360/using-proxy-interface-in-plotly-shiny-to-dynamically-change-data
# https://community.plot.ly/t/how-to-efficiently-restyle-update-modify-plot-containing-frames/5553
# https://plot.ly/javascript/animations/#frame-groups-and-animation-modes
# https://plot.ly/javascript/animations/
if (input$add){
cat("add trace\n")
my$fnumber <- my$fnumber + 1
my$ntraces <- my$ntraces + 2
f <- as.character(my$fnumber)
x <- runif(2)
y <- rep(runif(1), 2)
t <- c("A", "B")
ids0 <- paste0(my$ntraces-2, letters[1:2])
ids1 <- paste0(my$ntraces-1, letters[1:2])
my$frame$name <- f
my$frame$data[[my$ntraces-1]] <- list(x=x, y=y, frame=f, ids=ids0, type="scatter", mode="lines", showlegend=FALSE)
my$frame$data[[my$ntraces-0]] <- list(x=x, y=y, frame=f, ids=ids1, type="scatter", mode="text", text=t, showlegend=FALSE)
my$frame$traces <- as.list(as.integer(1:my$ntraces - 1))
plotlyProxyInvoke(proxy, "addTraces",
list(
my$frame$data[[my$ntraces-1]],
my$frame$data[[my$ntraces-0]]
))
plotlyProxyInvoke(proxy, "animate",
# frameOrGroupNameOrFrameList
list(
name = my$frame$name,
data = my$frame$data,
traces = my$frame$traces
),
# animationAttributes
list(
frame=list(duration=0),
transition=list(duration=0)
)
)# animate
}
if (input$animate){
cat("animate traces\n")
my$fnumber <- my$fnumber + 1
f <- as.character(my$fnumber)
traces <- 1:my$ntraces - 1
for (i in seq(0, my$ntraces-2, 2)){
x <- runif(2)
y <- rep(runif(1), 2)
t <- c("A", "B")
ids0 <- paste0(i, letters[1:2])
ids1 <- paste0(i+1, letters[1:2])
my$frame$data[[i+1]] <- list(x=x, y=y, frame=f, ids=ids0, type="scatter", mode="lines", showlegend=FALSE)
my$frame$data[[i+2]] <- list(x=x, y=y, frame=f, ids=ids1, type="scatter", mode="text", text=t, showlegend=FALSE)
}
my$frame$name <- f
plotlyProxyInvoke(proxy, "animate",
# frameOrGroupNameOrFrameList
list(
name = my$frame$name,
data = my$frame$data,
traces = my$frame$traces
),
# animationAttributes
list(
frame=list(duration=speed),
transition=list(duration=speed)
)
)# animate
}
if (input$rescale){
cat("animate layout\n")
my$fnumber <- my$fnumber + 1
f <- as.character(my$fnumber)
my$xrange <- runif(2)*0.1+c(-0.1,1)
my$frame$name <- f
my$frame$layout <- list(xaxis=list(range=my$xrange))
plotlyProxyInvoke(proxy, "animate",
# frameOrGroupNameOrFrameList
list(
name = my$frame$name,
data = my$frame$data,
traces = my$frame$traces,
layout = my$frame$layout
),
# animationAttributes
list(
frame=list(duration=speed),
transition=list(duration=speed)
)
) # animate
}
}) # observeEvent
}
shinyApp(ui, server)

Related

I can't get get the DT package to work correctly on Rshiny

I'm currently working on an Rshiny webapp to use for some simple classification. Currently, I've been working on creating a table that contains the CCR and MCR of both the CART and LDA methods on the data. My aim is then to highlight the column of the MCR and CCR of the best method (the method with the highest CCR... or lowest MCR). I have ran the code and viewed that it works correctly using the Viewer Pane. However, when I load the app, I obtain the error 'data' must be 2-dimensional (e.g. data frame or matrix).
Here is my code:
data <- read.csv("Fatality-task2.csv")
data$Rate <- as.factor(data$Rate)
library(shiny)
library(dplyr)
library(ggplot2)
library(markdown)
library(gtsummary)
library(ggdendro)
library(factoextra)
library(mclust)
library(cluster)
library(rpart)
library(rpart.plot)
library(DT)
#library(MASS)
glimpse(data)
#################################################################
ui <- fluidPage(
navbarPage("",
tabPanel("Data Exploration",
sidebarLayout(
sidebarPanel(
selectInput("variable",
"Variable",
colnames(data)),
selectInput("rate",
"Rate",
levels(data$Rate))
),
mainPanel(
tableOutput("table"),
plotOutput("plot")
)
)
),
tabPanel("Classification tools",
sidebarLayout(
sidebarPanel(
sliderInput("train.prop",
"Training data proportion",
min = 0.4,
max = 0.8,
step = 0.1,
value = 0.6),
radioButtons("prune",
"Pruning option",
choices = c("view pruned tree",
"view unpruned tree"))
),
mainPanel(
DTOutput("table2"),
plotOutput("plot2")
)
)
)
)
)
#################################################################
server <- function(input, output) {
output$table <- renderTable({
req(input$variable,input$rate)
data <- data %>%
filter(Rate == input$rate) %>%
dplyr::select(input$variable) %>%
summary() %>%
as.data.frame() %>%
tidyr::separate(Freq, c("Stat", "Value"), sep=":") %>%
tidyr::pivot_wider(names_from =Stat, values_from = Value)
data <- data[, -c(1,2)]
})
output$plot <- renderPlot({
req(input$variable)
if (input$variable == "jaild" | input$variable == "Rate"){
ggplot(data, aes(x = Rate, fill = .data[[as.name(input$variable)]])) +
geom_bar(position = "dodge", width = 0.7) +
if (input$variable == "Rate"){
theme(legend.position = "none")
}
} else {
ggplot(data, aes(x = Rate, y = .data[[as.name(input$variable)]], fill = Rate)) +
geom_boxplot() +
theme(legend.position = "none")
}
})
output$plot2 <- renderPlot({
req(input$train.prop,input$prune)
set.seed(1234)
n <- nrow(data)
ind1 <- sample(c(1:n), round(n*as.numeric(input$train.prop)))
ind2 <- sample(c(1:n)[-ind1], length(c(1:n)[-ind1]))
train.data <- data[ind1,]
valid.data <- data[ind2,]
fit.tree <- rpart(Rate~., data = train.data, method = "class")
ptree <- prune(fit.tree, cp = fit.tree$cptable[which.min(fit.tree$cptable[,"xerror"]),"CP"])
if (input$prune == "view pruned tree"){
rpart.plot(ptree, uniform =TRUE)
} else {
rpart.plot(fit.tree)
}
})
output$table2 <- DT::renderDT({
library(MASS)
set.seed(1234)
n <- nrow(data)
ind1 <- sample(c(1:n), round(n*0.6))
#ind2 <- sample(c(1:n)[-ind1], length(c(1:n)[-ind1]))
ind2 <- setdiff(c(1:n), ind1)
train.data <- data[ind1,]
valid.data <- data[ind2,]
#################################
### fit cart model
fit.tree <- rpart(Rate~., data = train.data, method = "class")
### prune the tree
ptree <- prune(fit.tree, cp = fit.tree$cptable[which.min(fit.tree$cptable[,"xerror"]),"CP"])
### predict using the validation data on the pruned tree
pred <- predict(ptree, newdata = valid.data[,-6], type = "class")
### lda
#lda.model <- lda(train.data[,-6], train.data[,6])
lda.model <- lda(Rate~., data = train.data)
lda.pred <- predict(lda.model, newdata = valid.data[,-6])
### create a classification table
length(lda.model)
x <- pred == valid.data[,6]
CCR <- length(x[x == TRUE])/nrow(valid.data)
MCR <- 1 - CCR
CR <- c(CCR, MCR)
z <- lda.pred$class == valid.data[,6]
lda.CCR <- length(z[z == TRUE])/nrow(valid.data)
lda.MCR <- 1 - lda.CCR
lda.CR <- c(lda.CCR, lda.MCR)
y <- cbind(CR, lda.CR)
y <- as.data.frame(y)
colnames(y) <- c("CART", "LDA")
rownames(y) <- c("CCR", "MCR")
#y
DT::datatable(y, options=list(dom = "t")) %>%
formatRound(columns = c(1,2), digits = 6) %>%
formatStyle(columns = colnames(y[which.max(y[1,])]), background = "green")
#colnames(y[1])
#colnames(y[which.max(y[1,])])
},
rownames = TRUE)
}
?formatStyle
?formatRound()
#################################################################
shinyApp(ui, server)
and here is some of my data:
"beertax","jaild","vmiles","unrate","perinc","Rate"
1.53937947750092,"no",7.23388720703125,14.3999996185303,10544.15234375,1
1.78899073600769,"no",7.83634765625,13.6999998092651,10732.7978515625,1
1.71428561210632,"no",8.262990234375,11.1000003814697,11108.791015625,1
1.65254235267639,"no",8.7269169921875,8.89999961853027,11332.626953125,1
1.60990703105927,"no",8.952853515625,9.80000019073486,11661.5068359375,1
1.55999994277954,"no",9.1663017578125,7.80000019073486,11944,1
1.50144362449646,"no",9.6743232421875,7.19999980926514,12368.6240234375,1
0.214797139167786,"yes",6.81015673828125,9.89999961853027,12309.0693359375,1
0.206422030925751,"yes",6.58749462890625,9.10000038146973,12693.8076171875,1
0.296703308820724,"yes",6.70997021484375,5,13265.93359375,1
0.381355941295624,"yes",6.7712626953125,6.5,13726.6953125,1
0.371517032384872,"yes",8.1290078125,6.90000009536743,14107.3271484375,1
0.360000014305115,"yes",9.370654296875,6.19999980926514,14241,1
0.346487015485764,"yes",9.815720703125,6.30000019073486,14408.0849609375,1
0.650358021259308,"no",7.20850048828125,9.80000019073486,10267.302734375,1
0.67545872926712,"no",7.1759169921875,10.1000003814697,10433.486328125,1
0.598901093006134,"no",7.08481982421875,8.89999961853027,10916.4833984375,1
0.577330529689789,"no",7.25391796875,8.69999980926514,11149.3642578125,1
0.562435507774353,"no",7.4689990234375,8.69999980926514,11399.380859375,1
0.545000016689301,"no",7.66583056640625,8.10000038146973,11537,1
0.52454286813736,"no",8.02462548828125,7.69999980926514,11760.3466796875,1
0.107398569583893,"no",6.8586767578125,9.89999961853027,15797.1357421875,0
0.103211015462875,"no",7.21629150390625,9.69999980926514,15970.18359375,0
0.0989011004567146,"no",7.61917578125,7.80000019073486,16590.109375,0
0.0953389853239059,"no",7.87406689453125,7.19999980926514,16985.169921875,0
0.0928792580962181,"no",8.03491015625,6.69999980926514,17356.037109375,0
0.0900000035762787,"no",8.18063330078125,5.80000019073486,17846,0
0.0866217538714409,"no",8.531990234375,5.30000019073486,18049.0859375,0
0.214797139167786,"no",7.742841796875,7.69999980926514,15082.3388671875,1
0.206422030925751,"no",7.65606298828125,6.59999990463257,15131.880859375,1
0.197802200913429,"no",7.7078525390625,5.59999990463257,15486.8134765625,0
0.190677970647812,"no",8.09220947265625,5.90000009536743,15569.9150390625,0
0.185758516192436,"no",8.13137451171875,7.40000009536743,15616.0986328125,0
0.180000007152557,"no",8.18202783203125,7.69999980926514,15605,0
0.173243507742882,"no",8.3807685546875,6.40000009536743,15845.04296875,0
0.224343672394753,"no",6.4400537109375,6.90000009536743,17255.369140625,0
0.233563080430031,"no",6.57004296875,6,17744.265625,0
0.248010993003845,"no",6.68019287109375,4.59999990463257,18760.439453125,0
0.239078402519226,"yes",6.97921484375,4.90000009536743,19312.5,0
I know the code works properly - I just want it to be able to run properly on the app. Please help!

Use the data rendered in output through DT::renderDataTable for further plotting

I have developed a shiny app, in which I am uploading a number of CSV files in each tab. After performing some mathematical operations on the uploaded data, I am getting N number of data tables as an output. I am rendering those data tables using DT::renderDataTable.
Now, let say I have 3 different datatables rendered using DT::renderDataTable I want to use the output rendered in those datatables to plot a combined graph. (3 geom_line() on top of each other)
This is how I am rendering the data in the datatable:
output$Data_FSC <- DT::renderDataTable({
x1 <- data2()[, c(input$xcol2, input$ycol2)]
M <- x1
#calculate rotation angle
alpha <- -atan((M[1,2]-tail(M,1)[,2])/(M[1,1]-tail(M,1)[,1]))
#rotation matrix
rotm <- matrix(c(cos(alpha),sin(alpha),-sin(alpha),cos(alpha)),ncol=2)
#shift, rotate, shift back
M2 <- t(rotm %*% (t(M)-c(M[1,1],M[1,2]))+c(M[1,1],M[1,2]))
M2[nrow(M2),2] <- M2[1,2]
M2
d_f3 <- data.frame(x = M2[,1], y = (M2[,2]-min(M2[1,2])))
v_f1 <- subset(d_f3, y > ((input$below2)/1000) & y < ((input$above2)/1000), select = c(x,y))
fla_upper2 <- lm(formula = y+((input$Upper_Poly_Limit2)/1000000) ~ poly(x,input$degree2, raw = TRUE), v_f1)
fla_lower2 <- lm(formula = y-((input$Lower_Poly_Limit2)/1000000) ~ poly(x,input$degree2, raw = TRUE), v_f1)
v_f1$upper2 <- predict(fla_upper2, newdata=v_f1)
v_f1$lower2 <- predict(fla_lower2, newdata=v_f1)
v_f1$region2 <- ifelse(v_f1[,2] <= v_f1$upper2 & v_f1[,2] >= v_f1$lower2, 'inside', 'outside')
kl <- subset(v_f1, region2 =='inside')
g <- ggplot() + theme_bw() +
geom_smooth(data = kl, aes_string(kl[,1], kl[,2]), formula = y ~ poly(x,input$degree_2, raw = TRUE), method = "lm", color = "green3", level = 1, size = 0.5)
r <- ggplot_build(g)$data[[1]]
q <- data.frame(x = r[,1], y = r[,2])
#calculate rotation angle
beta <- -atan((q[1,2]-tail(q,1)[,2])/(q[1,1]-tail(q,1)[,1]))
#rotation matrix
rot_m <- matrix(c(cos(beta),sin(beta),-sin(beta),cos(beta)),ncol=2)
#shift, rotate, shift back
M_2 <- t(rot_m %*% (t(q)-c(q[1,1],q[1,2]))+c(q[1,1],q[1,2]))
M_2[nrow(M_2),2] <- M_2[1,2]
M_2
M_3 <- data.frame(x= (M_2[,1]-median(M_2[,1])), y= (M_2[,2]-min(M_2[,2])))
the_data <- reactive(M_3)
the_data()
})
I tried feeding the output of the DT::renderDataTable as input for ggplot but my shiny app is showing me an error saying that
Reading from shinyoutput object is not allowed.
I already knew that 'Reading from shinyoutput object is not allowed'.
I just want to know whether there is any way I can use the output rendered in datatable for further plotting in a shiny app.
Here's a MWE demonstrating what I think you want to do.
Notice the separation of data from presentation: t1, t2 and t3 are reactives representing your CSV files. Each is rendered in a different data table. allData is a reactive containing union of the CSV data. This is used as the source data for the plot.
library(shiny)
library(DT)
library(tidyverse)
ui <- fluidPage(
numericInput("n", "Number of points:", min=2, max=20, value=10),
plotOutput("plot"),
dataTableOutput("table1"),
dataTableOutput("table2"),
dataTableOutput("table3")
)
server <- function(input, output) {
t1 <- reactive({ tibble(x=1:input$n, y=rnorm(input$n), key="Table 1") })
t2 <- reactive({ tibble(x=1:input$n, y=rnorm(input$n), key="Table 2") })
t3 <- reactive({ tibble(x=1:input$n, y=rnorm(input$n), key="Table 3") })
allData <- reactive({ bind_rows(t1(), t2(), t3()) })
output$table1 <- renderDT({ t1() })
output$table2 <- renderDT({ t2() })
output$table3 <- renderDT({ t3() })
output$plot <-renderPlot({ allData() %>% ggplot() + geom_line(aes(x=x, y=y, colour=key)) })
}
shinyApp(ui = ui, server = server)
It might be worth looking at using modules to manage and present the CSV files.

Smooth animation of axis change in R shiny plotly animation

I am writing a small shiny app to interactively display filtered data. I want to animate the transition in the data and in the axis bounds. No matter what I do I can't get the axis bounds to animate smoothly. Does anyone know how to do this?
# herd testing shiny app
version <- "v0.2"
library(shiny)
library(shinyjs)
library(readr)
library(dplyr)
library(stringr)
library(plotly)
library(purrr)
# notin function
"%notin%" <- function(x,y)!("%in%"(x,y))
# avoid as.numeric coercion warnings
as_numeric <- function(x, default=NA_real_){
suppressWarnings(if_else(is.na(as.numeric(x)), default, as.numeric(x)))
}
as_integer <- function(x, default=NA_integer_){
suppressWarnings(if_else(is.na(as.integer(x)), default, as.integer(x)))
}
# range including zero and handling NA
zrange <- function(x){
c(min(c(0, x), na.rm=TRUE), max(c(0, x), na.rm=TRUE))
}
# test data for reprex
data <- data.frame(
herd = rep(LETTERS, each=10),
year = rep(2010:2019, times=26),
count = sample(c(NA, 0:10), 260, TRUE),
percent = sample(c(NA, 0:10), 260, TRUE)/100
)
herds <- unique(data$herd)
herds1 <- sample(herds, 1)
# some colours
zzgreen <- "#69BE28"
zzblue <- "#009AA6"
ui <- fluidPage(
cat("run ui function\n"),
theme = shinythemes::shinytheme("spacelab"), # kinda similar to DairyNZ and plotly
align="center",
# https://www.w3schools.com/css/default.asp
fluidRow(
column(3,
strong("Select Herd:", style="font-size: 14px;"),
br(""),
textInput("herd", label="Enter Herd Code:", value=herds1)
),
column(9,
align="left",
strong("Herd Tests:", style="font-size: 14px;"),
plotlyOutput("count_plot", height="auto"),
strong("DNA Verified:", style="font-size: 14px;"),
plotlyOutput("perc_plot", height="auto")
)
),
fluidRow(
align="right",
em(version)
)
) # fluidPage
server <- function(input, output, session){
cat("run server function\n")
my <- reactiveValues(
herd = herds1,
frame = 0,
data = filter(data, herd==herds1),
speed = 500,
plist = list()
) # reactiveValues
observeEvent(input$herd, {
req(input$herd %in% herds)
my$herd <- input$herd
my$frame <- my$frame + 1
cat("new herd", input$herd, "new frame", my$frame, "calc plist\n")
# filter data
my$data <- data %>%
filter(herd==my$herd)
print(my$data)
# get existing list
pl <- my$plist
# herd test count data
pl[[1]] <- list(x=my$data$year,
y=my$data$count,
frame=my$frame,
name = "Herd Test Count",
showlegend=TRUE,
color=I(zzblue),
type="scatter",
mode="lines+markers")
# percent DNA verified data
pl[[2]] <- list(x=my$data$year,
y=my$data$percent*100,
frame=my$frame,
name = "Percent Verified",
showlegend=TRUE,
color=I(zzgreen),
type="scatter",
mode="lines+markers")
# https://plot.ly/r/multiple-axes/
# herd test count axis
pl[[3]] <- list(
title = list(text=my$herd),
xaxis=list(title=list(text="<b>Year</b>"),
tick0=min(my$data$year),
dtick=1,
range=range(my$data$year),
zeroline=FALSE,
type="linear"),
yaxis=list(title=list(text="<b>Herd Test Count</b>"),
zeroline=TRUE,
range=zrange(my$data$count),
type="linear"))
cat("range", zrange(my$data$count), "\n")
# percent DNA verified axis
pl[[4]] <- list(
xaxis=list(title=list(text="<b>Year</b>"),
tick0=min(my$data$year),
dtick=1,
range=range(my$data$year),
zeroline=FALSE,
type="linear"),
yaxis=list(title=list(text="<b>Percent Verified</b>"),
zeroline=TRUE,
range=zrange(my$data$percent*100),
type="linear"))
cat("range", zrange(my$data$percent*100), "\n")
# animation options
pl[[5]] <- list(frame=my$speed,
transition=my$speed,
redraw=FALSE,
mode="next")
pl[[6]] <- list(frame=0,
transition=0,
redraw=FALSE,
mode="next")
my$plist <- pl
})
output$count_plot <- renderPlotly({
cat("initial count_plot\n")
isolate({
# https://stackoverflow.com/questions/39019212/suppress-plotly-warnings-in-shiny-app
store_warn <- getOption("warn"); options(warn=-1)
pl <- my$plist
p <- plot_ly()
p <- do.call(add_trace, prepend(pl[[1]], list(p)))
p <- do.call(layout, prepend(pl[[3]], list(p)))
p <- do.call(animation_opts, prepend(pl[[5]], list(p)))
# restore warnings, delayed so plot is completed
shinyjs::delay(100, options(warn=store_warn))
p
})
}) # renderPlotly
count_plot_proxy <- plotlyProxy("count_plot", session=session)
output$perc_plot <- renderPlotly({
cat("initial perc_plot\n")
isolate({
# https://stackoverflow.com/questions/39019212/suppress-plotly-warnings-in-shiny-app
store_warn <- getOption("warn"); options(warn=-1)
pl <- my$plist
p <- plot_ly()
p <- do.call(add_trace, prepend(pl[[2]], list(p)))
p <- do.call(layout, prepend(pl[[4]], list(p)))
p <- do.call(animation_opts, prepend(pl[[5]], list(p)))
# restore warnings, delayed so plot is completed
shinyjs::delay(100, options(warn=store_warn))
p
})
}) # renderPlotly
perc_plot_proxy <- plotlyProxy("perc_plot", session=session)
observeEvent(my$herd, {
cat("new herd", my$herd, "update plots\n")
pl <- my$plist
# plotlyProxyInvoke(count_plot_proxy, "animate",
# list(
# name = as.character(my$frame),
# layout = pl[[3]]
# ),
# pl[[5]]
# )
plotlyProxyInvoke(count_plot_proxy, "animate",
list(
name = as.character(my$frame),
data = pl[1],
traces = as.list(as.integer(0)),
layout = pl[[3]]
),
pl[[5]]
)
# plotlyProxyInvoke(count_plot_proxy, "relayout",
# update = pl[3])
# plotlyProxyInvoke(perc_plot_proxy, "animate",
# list(
# name = as.character(my$frame),
# layout = pl[[4]]
# ),
# pl[[5]]
# )
plotlyProxyInvoke(perc_plot_proxy, "animate",
list(
name = as.character(my$frame),
data = pl[2],
traces = as.list(as.integer(0)),
layout = pl[[4]]
),
pl[[5]]
)
# plotlyProxyInvoke(count_plot_proxy, "relayout",
# update = pl[3])
}) # observeEvent
} # server
# run app
shinyApp(ui, server)
Thanks so much for your help, I am adding extra text here so that SO allows me to post this.

Building Quadrants in Rshiny

I wanna build quadrants on my leaflet as part of my quadrat analysis. currently I have my tessalation object and im trying to draw the tiles on my leaflet. My code is below
library(spatstat)
library(leaflet)
firms_ppp <- ppp(x=cbd_points#coords[,1],y=cbd_points#coords[,2], window =
window)
qc <- quadratcount(firms_ppp)
qc.nu <- as.numeric(qc)
qc.tess <- as.tess(qc)
colorpal4 <- colorNumeric("red",c(min(qc.nu, na.rm = TRUE),max(qc.nu, na.rm = TRUE)))
for (j in 1:length(qc.tess$window$yrange)) {
for (i in 1:length(qc.tess$window$xrange[i])) {
leaflet() %>%
addRectangles(lng1 = qc.tess$window$xrange[i], lng2 = qc.tess$window$xrange[i+1],
lat1 = rev(qc.tess$window$yrange)[j], lat2 = rev(qc.tess$window$yrange)[j+1],
color = colorpal4(qc.nu[j+(i-1)*(length(qc.tess$window$yrange)-1)]),
popup = paste("<h3>",qc.nu[j+(i-1)*(length(qc.tess$window$yrange)-1)],"</h3>")
)
}
}
Any idea how I can build the quadrants? I tried with tiles as well but I cant seem to get it to work too! Pls Help!!
With 2 helping functions found here, which convert a Tesselation object into SpatialPolygons, you can achieve something like this:
library(spatstat)
library(leaflet)
library(sp)
## FUNCTIONS #####################
owin2Polygons <- function(x, id="1") {
stopifnot(is.owin(x))
x <- as.polygonal(x)
closering <- function(df) { df[c(seq(nrow(df)), 1), ] }
pieces <- lapply(x$bdry,
function(p) {
Polygon(coords=closering(cbind(p$x,p$y)),
hole=spatstat.utils::is.hole.xypolygon(p)) })
z <- Polygons(pieces, id)
return(z)
}
tess2SP <- function(x) {
stopifnot(is.tess(x))
y <- tiles(x)
nom <- names(y)
z <- list()
for(i in seq(y))
z[[i]] <- owin2Polygons(y[[i]], nom[i])
return(SpatialPolygons(z))
}
## DATA #####################
cbd_points <- data.frame(
long = runif(100,15,19),
lat = runif(100,40,50)
)
window <- owin(c(0,20), c(30,50))
firms_ppp <- ppp(x=cbd_points$long, y=cbd_points$lat, window = window)
qc <- quadratcount(firms_ppp)
qc.nu <- as.numeric(qc)
qc.tess <- as.tess(qc)
colorpal4 <- colorNumeric("red",c(min(qc.nu, na.rm = TRUE),max(qc.nu, na.rm = TRUE)))
PolyGrid <- tess2SP(qc.tess)
PolyGridDF <- SpatialPolygonsDataFrame(PolyGrid, data = data.frame(ID = 1:length(PolyGrid)), match.ID = F)
## SHINY ########################
library(shiny)
ui <- fluidPage(
leafletOutput("map")
)
server <- function(input, output, session) {
output$map <- renderLeaflet({
pal = colorFactor("viridis", as.character(PolyGridDF$ID))
leaflet() %>%
addTiles() %>%
addPolygons(data=PolyGridDF,
label = as.character(PolyGridDF$ID),
color = ~pal(as.character(PolyGridDF$ID)))
})
}
shinyApp(ui, server)

Conditional checkbox plotting in Shiny

I have two checkbox group fiscal and manager. When a particular value from fiscal check box say 2016Q1 is selected and if a checkbox from manager is ticked, the application should plot the graph from 2016Q1fiscal year for that manager. I have written logic for both the checkboxes individually but am unable to integrate that.
library(shiny)
library(shinythemes)
ui <- fluidPage(theme = shinytheme("journal"),h1("India-DSI",align="center",style = "font-family: 'Lobster', cursive;font-weight: 500; line-height: 1.1; color: #4d3a7d;"),
sidebarLayout(
sidebarPanel(fileInput('file1', 'Choose file to upload',accept= c('text/csv','text/comma-separated-values','text/tab-separated-values','text/plain','.csv','.tsv')),width=2,
checkboxGroupInput("fiscal", "Fiscal Quarter:", c("2015Q1","2015Q2","2015Q3","2015Q4","2016Q1"),selected = NULL,inline=FALSE),
checkboxGroupInput("manager", "Manager:", c("Kalla,Abhay","Koul,Samir","Pudipeddi,Harinath","Huruli,Sharath"),selected = NULL,inline = FALSE)
),
mainPanel({
plotOutput("plot")
})))
server <- function (input , output )
{
myread <- function ()
{
inFile <- input$file1
if (is.null(inFile))
return(NULL)
mydata <- read.csv(inFile$datapath)
return (mydata)
}
## Quarter filter
{
output$plot <- renderPlot({
x <- data.frame(myread())
y <- x[x$Fiscal.Quarter == input$fiscal, ]
resources <- factor(y$Resource.Name)
stan <- tapply(y$Standard.Hours, resources, sum, na.rm = TRUE)
bil <- tapply(y$Billable.Hours, resources, sum, na.rm = TRUE)
bu <- bil*100 / stan
mp <- barplot (bu, col = colors(27), las = 2, yaxt = "n",xlim=NULL, ylim = c(0,200))
bu<- round(bu, 2)
text(mp, bu, labels = bu, pos = 3)
})
}
## Manager Filter
{
output$plot <- renderPlot({
x <- data.frame(myread())
y <- x[x$Manager == input$manager, ]
resources <- factor(y$Resource.Name)
stan <- tapply(y$Standard.Hours, resources, sum, na.rm = TRUE)
bil <- tapply(y$Billable.Hours, resources, sum, na.rm = TRUE)
bu <- bil*100 / stan
mp <- barplot (bu, col = colors(27), las = 2, yaxt = "n", ylim = c(0,200))
bu<- round(bu, 2)
text(mp, bu, labels = bu, pos = 3)
})
}
}
shinyApp(ui=ui ,server=server)

Resources