When the app loads, the legend names show as “trace 0” and “trace 1” until the second frame of the animation loads. How do I get them to show immediately on render? Thanks.
PS. This code should run fine for you.
#### global ####
# this code is run once, global for all sessions
# https://shiny.rstudio.com/tutorial/written-tutorial/lesson5/
library(shiny)
library(plotly)
library(dplyr)
library(XML)
library(curl)
# start app
cat("\n")
cat("STARTING APP ................ \n")
# utility functions
"%notin%" <- function(x,y)!("%in%"(x,y))
numerify_factor <- function(f){as.numeric(as.character(f))}
# set up
ev_vars <- c("fat", "protein", "milk", "liveweight", "residual_survival",
"somatic_cell", "fertility", "body_condition_score")
ev_names <- c("Milk Fat", "Milk Protein", "Milk Volume", "Live Weight",
"Residual Survival", "Somatic Cell Count", "Fertility",
"Body Condition Score")
breed_order <- c("All Breeds", "Friesian", "Jersey", "Cross", "Ayrshire", "Other")
# read functions
read_yr <- function(){
substr(Sys.time(),1,4)
}
read_ev <- function(){
cat("reading EV data from website...\n")
url <- "https://www.dairynz.co.nz/animal/animal-evaluation/interpreting-the-info/economic-values/"
con <- curl::curl(url)
xdata <- readLines(con)
close(con)
ev <- tibble::as_tibble(XML::readHTMLTable(xdata, header=TRUE)[[1]])
ev <- ev %>%
magrittr::set_colnames(tolower(names(ev))) %>%
dplyr::mutate(
ev_var = ev_vars,
ev_name = ev_names,
trait = as.character(trait)
)
year <- read_yr()
if (year %notin% names(ev)){
cat("Error: EV values not found for", year, "\n")
showNotification("EV values not found; using defaults...")
ev[[year]] <- factor(c(3.49, 4.38, -0.092, -1.30, 0.112, -37.3, 5.88, 96.3))
}
ev[[year]] <- numerify_factor(ev[[year]])
ev$ev_min <- round(pmin(ev[[year]] * -0.5, ev[[year]] * 2.5), 2) # could be negative
ev$ev_max <- round(pmax(ev[[year]] * -0.5, ev[[year]] * 2.5), 2) # could be negative
ev$ev_step <- (ev$ev_max - ev$ev_min) / 50 # bigger steps look better
return(ev)
}
bv_breeds <- c("Friesian", "Jersey", "Cross", "Other")
breed_text <- c("Friesian"="F", "Jersey"="J", "Cross"="X", "Other"="O")
bv_breeds_all <- as.list(c(bv_breeds, "All"))
read_bv <- function(){
cat("reading RAS data from website...\n")
url <- "https://www.dairynz.co.nz/animal/animal-evaluation/ranking-of-active-sires-ras/"
con <- curl::curl(url)
xdata <- readLines(con)
close(con)
temp <- XML::readHTMLTable(xdata, header=TRUE) # read all tables
bv <- vector("list", 4)
bv_names <- c("name", "bw_rel", ev_vars[c(2,1,3,4,7,6,5,8)])
endstr <- function(x, n){substr(x, nchar(x)-n+1, nchar(x))}
for (i in 1:4){
j <- c(6,11,16,21)[i]
bv[[i]] <- tibble::as_tibble(temp[[j]]) %>%
dplyr::select(seq_along(bv_names)) %>%
magrittr::set_colnames(bv_names) %>%
dplyr::mutate(breed=bv_breeds[i],
breedcode=endstr(as.character(temp[[j+1]][[2]]),3) # breed code is in next table
)
}
bv <- suppressWarnings(dplyr::bind_rows(bv)) # converts factors to character
bv <- bv %>%
dplyr::mutate_at(ev_vars, numerify_factor) %>%
dplyr::mutate_at(bv_names[1:2], as.character)%>%
dplyr::rename(bull=name)
return(bv)
}
# calculate initial BW for bv using matrix mult
bwm <- function(bv, ev_vars, ev_this_year){
bvm <- as.matrix(dplyr::select(bv, one_of(ev_vars)))
i <- match(ev_vars, colnames(bvm))
evm <- as.numeric(as.matrix(ev_this_year[i]))
round(bvm %*% evm, 1)
}
topn <- 10 # coloured blue
shown <- 20 # extent of graph
plotn <- 1000 # actually plotted
#c0c2c0 – Grey
#a5d77e – Green
#6dc9d0 – Blue
# define colours
dnzblack <- "black"
dnzwhite <- "white"
dnzslate <- "#353735"
dnzlightslate <- "#b5c2bc" # https://www.color-hex.com/color-palette/18977
dnzpaleslate <- "#f4f3f3" # https://www.color-hex.com/color-palette/18977
dnzdaveslate <- "#c0c2c0"
dnzgreen <- "#69BE28"
dnzlightgreen <- "#74ff8b" # https://www.color-hex.com/color-palette/77235
dnzpalegreen <- "#abffad" # https://www.color-hex.com/color-palette/77235
dnzdavegreen <- "#a5d77e"
dnzblue <- "#009AA6"
dnzlightblue <- "#94d1e4" # https://www.color-hex.com/color-palette/76824
dnzpaleblue <- "#bee3ee" # https://www.color-hex.com/color-palette/76824
dnzdaveblue <- "#6dc9d0"
dnzred <- "#ff0000" # https://www.color-hex.com/color-palette/76991
dnzdarkred <- "#b30033" # https://www.color-hex.com/color-palette/76991
if (FALSE){
scales::show_col(c(dnzslate, dnzlightslate, dnzpaleslate, dnzdaveslate,
dnzgreen, dnzlightgreen, dnzpalegreen, dnzdavegreen,
dnzblue, dnzlightblue, dnzpaleblue, dnzdaveblue,
dnzred, dnzdarkred))
}
#### ui ####
# https://gist.github.com/guybowden/90f42413649148df7632
sliderstyle <- gsub("#000069", dnzblue,
".irs-single, .irs-bar-edge, .irs-bar {background: #000069; border-top: 1px solid #000039; border-bottom: 1px solid #000039;}
.irs-from, .irs-to, .irs-single {background: #000069;}
.irs {margin: 0px 0px;}"
)
ui <- fluidPage(
theme = shinythemes::shinytheme("spacelab"), # kinda similar to DairyNZ and plotly
align="center",
# https://www.w3schools.com/css/default.asp
fluidRow(
column(4,
strong("Economic Values", style="font-size: 14px;"),
br(""),
tags$style(HTML(sliderstyle)),
uiOutput("sliders")
),
column(8,
align="left",
uiOutput("radio1"),
uiOutput("check1"),
strong("Bull Rank", style="font-size: 14px"),
plotlyOutput("bull_plot")
)
)
) # fluidPage
#### server ####
# this code is run once when a user visits the app
server <- function(input, output, session){
yrin <- reactiveVal(read_yr())
evin <- reactiveVal()
bvin <- reactiveVal()
fcount <- reactiveVal()
bwrange <- reactiveVal()
output$radio1 <- renderUI({
cat("render radioButtons\n")
radioButtons("radio",
strong("Display:", style="font-size: 14px"),
choices=list("Current EV"=1, "Slider EV"=2, "Reset Sliders"=3),
selected=2,
inline=TRUE)
})
selbreeds <- reactiveVal(bv_breeds_all)
output$check1 <- renderUI({
cat("render checkboxGroupInput\n")
checkboxGroupInput("check",
strong("Breeds:", style="font-size: 14px"),
choices=bv_breeds_all,
selected=bv_breeds_all,
inline=TRUE)
})
# https://groups.google.com/forum/#!topic/shiny-discuss/xW8f5g5gm4s
output$sliders <- renderUI({
cat("read ev and bv\n")
showNotification("Reading EV data...")
ev <- read_ev()
evin(ev)
showNotification("Reading RAS data...")
bv <- read_bv()
bv <- bv %>%
dplyr::mutate(id = as.character(1:n()),
bulltext = paste0("<b>",bull,"</b>"),
breedtext = paste0("<b>",breedcode,"</b>"),
bwm = bwm(., ev_vars, ev[[yrin()]]),
bwr = as.numeric(rank(-bwm, ties.method="first")),
y = shown-bwr+1,
top = (bwr <= topn)) # top bulls ranked on current EV
bvin(bv)
bwrange(as.numeric(c(min(bv$bwm)-150, max(bv$bwm)+50))) # save fixed chart range
cat("render sliderInputs\n")
sliders <- vector("list", 8)
for (i in 1:8){
# https://www.w3schools.com/css/default.asp
sliders[[i]] <- sliderInput(paste0("ev",i),
strong(ev$trait[i], style="line-height: 0.0; font-size: 14px"),
ev$ev_min[i],
ev$ev_max[i],
ev[[yrin()]][i],
ev$ev_step[i]
)
}
return(sliders)
})
output$bull_plot <- renderPlotly({
cat("initial renderPlotly\n")
f <- 1
fcount(f)
bv <- isolate(bvin())
topten <- bv %>%
dplyr::filter(top) %>%
dplyr::select(bwm, y, bulltext, id, breedtext)
others <- bv %>%
dplyr::filter(!top) %>%
dplyr::select(bwm, y, bulltext, id, breedtext)
xrange <- isolate(bwrange())
xmin <- xrange[1]
xmax <- xrange[2]
xname <- 5
yrange <- c(1-0.5, shown+0.5)
yticks <- as.list(seq(0,shown+1))
ylabels <- as.list(paste0(c("", seq(shown,1), ""), " "))
topten <- topten %>%
mutate(bwm=xmin-20, bulltext="", breedtext="") %>%
bind_rows(., topten, .) %>%
arrange(id) %>%
mutate(id=paste0(id,rep_len(c("a","b","c"),n())))
others <- others %>%
mutate(bwm=xmin-20, bulltext="", breedtext="") %>%
bind_rows(., others, .) %>%
arrange(id) %>%
mutate(id=paste0(id,rep_len(c("a","b","c"),n())))
# print(topten)
plot_ly(height=700) %>%
# put animation aesthetics first, then I can just copy this code to animation and comment out tail
add_trace(x=topten$bwm, y=topten$y, frame=f, ids=topten$id, name="Top Ten", line=list(width=20, simplify=FALSE), type="scatter", opacity=1, color=I(dnzblue), mode="lines", hoverinfo="x") %>%
add_trace(x=others$bwm, y=others$y, frame=f, ids=others$id, name="Other", line=list(width=20, simplify=FALSE), type="scatter", opacity=1, color=I(dnzgreen), mode="lines", hoverinfo="x") %>%
add_trace(x=topten$bwm-xname, y=topten$y, frame=f, ids=topten$id, text=topten$bulltext, textposition="middle left", color=I(dnzwhite), textfont=list(), type="scatter", mode="text", showlegend=FALSE, hoverinfo="none") %>%
add_trace(x=others$bwm-xname, y=others$y, frame=f, ids=others$id, text=others$bulltext, textposition="middle left", color=I(dnzwhite), textfont=list(), type="scatter", mode="text", showlegend=FALSE, hoverinfo="none") %>%
add_trace(x=topten$bwm+xname, y=topten$y, frame=f, ids=topten$id, text=topten$breedtext, textposition="middle right", color=I(dnzdaveslate), textfont=list(), type="scatter", mode="text", showlegend=FALSE, hoverinfo="none") %>%
add_trace(x=others$bwm+xname, y=others$y, frame=f, ids=others$id, text=others$breedtext, textposition="middle right", color=I(dnzdaveslate), textfont=list(), type="scatter", mode="text", showlegend=FALSE, hoverinfo="none") %>%
layout(xaxis=list(range=xrange, title=list(text="<b>BW</b>"), tickprefix="$", zeroline=FALSE, type="linear", fixedrange=TRUE),
yaxis=list(range=yrange, title=list(text="<b>Rank</b>"), zeroline=FALSE, ticktext=ylabels, tickmode="array", tickvals=yticks, type="linear", fixedrange=TRUE),
legend=list(orientation="h", x=0.1, y=1.06)) %>%
animation_opts(frame=500, redraw=FALSE)
}) # renderPlotly
observeEvent(input$check, ignoreNULL=FALSE, {
req(selbreeds())
req(!setequal(selbreeds(),input$check)) # if they are equal do nothing
cat("observed checkbox\n")
cat("old selbreeds() = ", paste(selbreeds()), "\n")
cat("new input$check = ", paste(input$check), "\n")
if ("All" %notin% selbreeds() && "All" %in% input$check){
# rule 1 - setting All resets everything
selbreeds(bv_breeds_all)
} else if (length(input$check)<1){
# rule 2 - can't unset last breed
# do nothing
} else if ("All" %in% selbreeds() && "All" %notin% input$check){
# rule 3 - unsetting All does nothing
# do nothing
} else if (length(input$check)<length(selbreeds())){
# rule 4 - unsetting any breed unsets All
selbreeds(setdiff(input$check, "All"))
} else if (setequal(union(input$check, "All"), bv_breeds_all)){
# rule 5 - setting the last breed sets All
selbreeds(bv_breeds_all)
} else {
# accept change as is
selbreeds(input$check)
}
# update checkboxes
updateCheckboxGroupInput(session, "check", selected=selbreeds())
})
observeEvent({
input$ev1
input$ev2
input$ev3
input$ev4
input$ev5
input$ev6
input$ev7
input$ev8
input$radio
selbreeds()
},{
# this whole section is isolated
# req(NULL) # turn this off, for testing
req(input$radio)
req(selbreeds())
cat("observed user input\n")
cat("input$radio = ", input$radio, "\n")
cat("selbreeds() = ", paste(selbreeds()), "\n")
# deal with radioButtons
if (input$radio %in% 3){ # reset sliders
ev_this_year <- evin()[[yrin()]]
for (i in 1:8){
updateSliderInput(session, paste0("ev",i), value=ev_this_year[i])
}
updateRadioButtons(session, "radio", selected=2)
req(NULL)
}
if (input$radio %in% 2){ # show user ev
ev_future <- c(
input$ev1,
input$ev2,
input$ev3,
input$ev4,
input$ev5,
input$ev6,
input$ev7,
input$ev8
)
cat("ev =", paste(ev_future), "\n")
ev_new <- ev_future
} else { # show original ev
ev_this_year <- evin()[[yrin()]]
ev_new <- ev_this_year
}
# recalc ranks
cat("update bw and rank\n")
f <- isolate(fcount()) + 1
fcount(f)
bv <- isolate(bvin())
bv$bwm <- bwm(bv, ev_vars, ev_new)
i <- bv$breed %in% selbreeds()
bv$bwr <- as.numeric(rank(if_else(i, -bv$bwm, -(bv$bwm-1000)), ties.method="first"))
bv$y <- if_else(i, shown-bv$bwr+1, -bv$bwr/100)
topten <- bv %>%
dplyr::filter(top) %>%
dplyr::select(bwm, y, bulltext, id, breedtext)
others <- bv %>%
dplyr::filter(!top) %>%
dplyr::select(bwm, y, bulltext, id, breedtext)
xrange <- isolate(bwrange())
xmin <- xrange[1]
xmax <- xrange[2]
xname <- 5
yrange <- c(1-0.5, shown+0.5)
yticks <- as.list(seq(0,shown+1))
ylabels <- as.list(paste0(c("", seq(shown,1), ""), " "))
topten <- topten %>%
mutate(bwm=xmin-20, bulltext="", breedtext="") %>%
bind_rows(., topten, .) %>%
arrange(id) %>%
mutate(id=paste0(id,rep_len(c("a","b","c"),n())))
others <- others %>%
mutate(bwm=xmin-20, bulltext="", breedtext="") %>%
bind_rows(., others, .) %>%
arrange(id) %>%
mutate(id=paste0(id,rep_len(c("a","b","c"),n())))
# print(topten)
# https://plot.ly/javascript/plotlyjs-function-reference/#plotlyanimate
cat("update bull_plot\n")
plotlyProxy("bull_plot", session=session, deferUntilFlush=FALSE) %>%
plotlyProxyInvoke("animate",
# frameOrGroupNameOrFrameList
list(
data = list(
# copy add_trace and convert to list of aesthetics that change
list(x=topten$bwm, y=topten$y, frame=f, ids=topten$id, name="Top Ten"), # line=list(width=20, simplify=FALSE), type="scatter", opacity=1, color=I(dnzblue), mode="lines", showlegend=FALSE, hoverinfo="x") %>%
list(x=others$bwm, y=others$y, frame=f, ids=others$id, name="Other"), # line=list(width=20, simplify=FALSE), type="scatter", opacity=1, color=I(dnzgreen), mode="lines", showlegend=FALSE, hoverinfo="x") %>%
list(x=topten$bwm-xname, y=topten$y, frame=f, ids=topten$id, text=topten$bulltext, textposition="middle left"), # color=I(dnzwhite), textfont=list(), type="scatter", mode="text", showlegend=FALSE, hoverinfo="none") %>%
list(x=others$bwm-xname, y=others$y, frame=f, ids=others$id, text=others$bulltext, textposition="middle left"), # color=I(dnzwhite), textfont=list(), type="scatter", mode="text", showlegend=FALSE, hoverinfo="none") %>%
list(x=topten$bwm+xname, y=topten$y, frame=f, ids=topten$id, text=topten$breedtext, textposition="middle right"), # color=I(dnzdaveslate), textfont=list(), type="scatter", mode="text", showlegend=FALSE, hoverinfo="none") %>%
list(x=others$bwm+xname, y=others$y, frame=f, ids=others$id, text=others$breedtext, textposition="middle right") #, color=I(dnzdaveslate), textfont=list(), type="scatter", mode="text", showlegend=FALSE, hoverinfo="none") %>%
),
traces = as.list(0:5),
layout = list()
),
# animationAttributes
list()
)# plotlyProxyInvoke
}) # observeEvent
} # server
shinyApp(ui, server)