# 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)
非常感谢你的帮助,我在这里添加了额外的文本,这样我就可以发布这篇文章了。
