My shiny app shows text that moves when the data is changed. I noticed that sometimes the grey text to the right of the bar reverts to textposition=“middle center” during animation, where is was set at “middle right”. Bug in plotly.js?
library(shiny)
library(plotly)
library(dplyr)
library(XML)
library(RCurl)
# 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")
# get ev data from website (or wherever)
cat("Get EV data from website\n")
url <- "https://www.dairynz.co.nz/animal/animal-evaluation/interpreting-the-info/economic-values/"
xdata <- RCurl::getURL(url)
ev <- tibble::as_tibble(XML::readHTMLTable(xdata, header=TRUE)[[1]])
ev <- ev %>%
magrittr::set_colnames(tolower(names(ev))) %>%
mutate(
ev_var = ev_vars,
ev_name = ev_names,
trait = as.character(trait)
)
this_year <- as.character(year(Sys.time()))
cat("System clock says it's", this_year, "\n")
if (this_year %notin% names(ev)){
cat("Error: EV values not found for", this_year, "\n")
ev[[this_year]] <- factor(c(3.49, 4.38, -0.092, -1.30, 0.112, -37.3, 5.88, 96.3))
}
ev[[this_year]] <- numerify_factor(ev[[this_year]])
ev$ev_min <- round(pmin(ev[[this_year]] * 0.5, ev[[this_year]] * 1.5), 2) # could be negative
ev$ev_max <- round(pmax(ev[[this_year]] * 0.5, ev[[this_year]] * 1.5), 2) # could be negative
ev$ev_step <- (ev$ev_max - ev$ev_min)/50 # bigger steps look better
print(ev)
# read bull data 2
cat("Get RAS data from website\n")
url <- "https://www.dairynz.co.nz/animal/animal-evaluation/ranking-of-active-sires-ras/"
xdata <- RCurl::getURL(url)
temp <- XML::readHTMLTable(xdata, header=TRUE) # read all tables
bv <- vector("list", 4)
bv_breeds <- c("F", "J", "X", "O")
bv_breeds <- c("Friesian", "Jersey", "Cross", "Other")
bv_names <- c("name", "bw_rel", ev_vars[c(2,1,3,4,7,6,5,8)])
for (i in 1:4){
j <- c(6,11,16,21)[i]
bv[[i]] <- tibble::as_tibble(temp[[j]]) %>%
select(seq_along(bv_names)) %>%
magrittr::set_colnames(bv_names) %>%
mutate(breed=bv_breeds[i])
}
bv <- suppressWarnings(bind_rows(bv)) # converts factors to character
bv <- bv %>%
mutate_at(ev_vars, numerify_factor) %>%
mutate_at(bv_names[1:2], as.character)
# calculate initial BW for bv using matrix mult
ev_this_year <- ev[[this_year]]
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
totn <- 20
bv$f <- 1
bv$bwm <- bwm(bv, ev_vars, ev_this_year)
bv$bwr <- rank(-bv$bwm, ties.method="first")
bv$top <- (bv$bwr <= topn) # top bulls ranked on current EV
bv <- bv %>%
dplyr::rename(bullname=name) %>%
dplyr::filter(bwr<=100) # reduce data
# define colours
dnzwhite <- "white"
dnzdaveslate <- "#e6e6e6"
dnzgreen <- "#69BE28"
dnzblue <- "#009AA6"
#### 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"),
strong("Bull Rank", style="font-size: 14px"),
plotlyOutput("bull_plot")
)
)
) # fluidPage
#### server ####
server <- function(input, output, session){
output$radio1 <- renderUI(radioButtons("radio",
strong("Display:", style="font-size: 14px"),
choices=list("Current Rank"=1, "Future Rank"=2, "Reset Sliders"=3),
selected=2,
inline=TRUE))
# https://groups.google.com/forum/#!topic/shiny-discuss/xW8f5g5gm4s
output$sliders <- renderUI({
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[[this_year]][i],
ev$ev_step[i]
)
}
return(sliders)
})
output$bull_plot <- renderPlotly({
cat("renderPlotly\n")
topten <- dplyr::filter(bv, top) %>%
dplyr::select(bwm, bwr, bullname, breed, f) %>%
dplyr::filter(bwr<=totn)
others <- dplyr::filter(bv, !top) %>%
dplyr::select(bwm, bwr, bullname, breed, f) %>%
dplyr::filter(bwr<=totn)
xmin <- 0
xname <- 5
xmax <- max(topten$bwm)*1.2
xrange <- list(xmin, xmax)
yrange <- list(0, topn*2+1)
yticks <- as.list(c(0:(topn*2+1)))
ylabels <- as.list(paste0(c("", 1:(topn*2), ""), " "))
topten <- bind_rows(mutate(topten, bwm=xmin-20, bullname="", breed=""),
topten,
mutate(topten, bwm=xmin-20, bullname="", breed="")) %>%
arrange(bwr)
others <- bind_rows(mutate(others, bwm=xmin-20, bullname="", breed=""),
others,
mutate(others, bwm=xmin-20, bullname="", breed="")) %>%
arrange(bwr)
plot_ly(height=700) %>%
add_trace(x=topten$bwm, y=topten$bwr, frame=topten$f, line=list(width=20, simplify=FALSE), type="scatter", opacity=1, color=I(dnzblue), mode="lines", showlegend=FALSE, hoverinfo="x") %>%
add_trace(x=others$bwm, y=others$bwr, frame=others$f, line=list(width=20, simplify=FALSE), type="scatter", opacity=1, color=I(dnzgreen), mode="lines", showlegend=FALSE, hoverinfo="x") %>%
add_trace(x=topten$bwm-xname, y=topten$bwr, frame=topten$f, text=paste0("<b>",topten$bullname,"</b>"), color=I(dnzwhite), textfont=list(), textposition="middle left", type="scatter", mode="text", showlegend=FALSE, hoverinfo="none") %>%
add_trace(x=others$bwm-xname, y=others$bwr, frame=others$f, text=paste0("<b>",others$bullname,"</b>"), color=I(dnzwhite), textfont=list(), textposition="middle left", type="scatter", mode="text", showlegend=FALSE, hoverinfo="none") %>%
add_trace(x=topten$bwm+xname, y=topten$bwr, frame=topten$f, text=paste0("<b>",topten$breed,"</b>"), color=I(dnzdaveslate), textfont=list(), textposition="middle right", type="scatter", mode="text", showlegend=FALSE, hoverinfo="none") %>%
add_trace(x=others$bwm+xname, y=others$bwr, frame=others$f, text=paste0("<b>",others$breed,"</b>"), color=I(dnzdaveslate), textfont=list(), textposition="middle right", type="scatter", mode="text", showlegend=FALSE, hoverinfo="none") %>%
layout(xaxis=list(range=xrange, title=list(text="<b>BW</b>"), tickprefix="$"),
yaxis=list(range=yrange, title=list(text="<b>Rank</b>"), autorange="reversed", dtick=1, zeroline=FALSE, ticktext=ylabels, tickmode="array", tickvals=yticks)
) %>%
animation_opts(frame=500, transition=500, redraw=FALSE)
})
observeEvent({
input$ev1
input$ev2
input$ev3
input$ev4
input$ev5
input$ev6
input$ev7
input$ev8
input$radio
},{
cat("observed input\n")
ev_future <- c(
input$ev1,
input$ev2,
input$ev3,
input$ev4,
input$ev5,
input$ev6,
input$ev7,
input$ev8
)
print(ev_future)
cat("input$radio = ", input$radio, "\n")
if (input$radio %in% 3){ # reset sliders
for (i in 1:8){
updateSliderInput(session, paste0("ev",i), value=ev[[this_year]][i])
}
updateRadioButtons(session, "radio", selected=2)
}
if (input$radio %in% c(1,3)){
bv$f <- bv$f + 1
bv$bwm <- bwm(bv, ev_vars, ev_this_year)
bv$bwr <- rank(-bv$bwm, ties.method="first")
} else {
bv$f <- bv$f + 1
bv$bwm <- bwm(bv, ev_vars, ev_future)
bv$bwr <- rank(-bv$bwm, ties.method="first")
}
cat("update data\n")
topten <- dplyr::filter(bv, top) %>%
dplyr::select(bwm, bwr, bullname, breed, f) %>%
dplyr::filter(bwr<=totn)
others <- dplyr::filter(bv, !top) %>%
dplyr::select(bwm, bwr, bullname, breed, f) %>%
dplyr::filter(bwr<=totn)
xmin <- 0
xname <- 5
xmax <- max(topten$bwm)*1.2
xrange <- list(xmin, xmax)
yrange <- list(1, topn*2)
topten <- bind_rows(mutate(topten, bwm=xmin-20, bullname="", breed=""),
topten,
mutate(topten, bwm=xmin-20, bullname="", breed="")) %>%
arrange(bwr)
others <- bind_rows(mutate(others, bwm=xmin-20, bullname="", breed=""),
others,
mutate(others, bwm=xmin-20, bullname="", breed="")) %>%
arrange(bwr)
# https://plot.ly/javascript/plotlyjs-function-reference/#plotlyanimate
cat("update bull_plot\n")
# add_trace(x=topten$bwm, y=topten$bwr, frame=topten$f, line=list(width=20, simplify=FALSE), type="scatter", opacity=1, color=I(dnzred), mode="lines", name=paste("Top", topn)) %>%
# add_trace(x=others$bwm, y=others$bwr, frame=others$f, line=list(width=20, simplify=FALSE), type="scatter", opacity=1, color=I(dnzblue), mode="lines", name="Others") %>%
# add_trace(x=topten$bwm-xname, y=topten$bwr, frame=topten$f, text=paste0("<b>",topten$bullname,"</b>"), color=I(dnzwhite), textfont=list(), textposition="middle left", type="scatter", mode="text", showlegend=FALSE) %>%
# add_trace(x=others$bwm-xname, y=others$bwr, frame=others$f, text=paste0("<b>",others$bullname,"</b>"), color=I(dnzwhite), textfont=list(), textposition="middle left", type="scatter", mode="text", showlegend=FALSE) %>%
plotlyProxy("bull_plot", session=session, deferUntilFlush=FALSE) %>%
plotlyProxyInvoke("animate",
# frameOrGroupNameOrFrameList
list(
data = list( # new data for each traces in the original plot
list(x = topten$bwm, y = topten$bwr, frame = topten$f),
list(x = others$bwm, y = others$bwr, frame = others$f),
list(x = topten$bwm-xname, y = topten$bwr, text = paste0("<b>",topten$bullname,"</b>"), frame = topten$f),
list(x = others$bwm-xname, y = others$bwr, text = paste0("<b>",others$bullname,"</b>"), frame = others$f),
list(x = topten$bwm+xname, y = topten$bwr, text = paste0("<b>",topten$breed,"</b>"), frame = topten$f),
list(x = others$bwm+xname, y = others$bwr, text = paste0("<b>",others$breed,"</b>"), frame = others$f)
),
traces = list( # trace numbers starting at 0
as.integer(0),
as.integer(1),
as.integer(2),
as.integer(3),
as.integer(4),
as.integer(5)
),
layout = list()
),
# animationAttributes
list()
)# plotlyProxyInvoke
})
} # server
shinyApp(ui, server)