This app ranks bulls according to economic values which the user can change. Weirdly, changing the sliders makes the plot and data table disappear, even though there is no error. Can any help me? Thanks
# set version number
version <- "NZAEL v0.40"
# reduce plot series to green, blue, white, grey
# initial plot working
# included option to use web data
#
# https://stackoverflow.com/questions/41597136/loading-data-from-dropbox-directly-in-shiny-app
#### global ####
cat("\nrun global code\n")
# this code is run once, global for all sessions
# https://shiny.rstudio.com/tutorial/written-tutorial/lesson5/
library(shiny)
library(shinyjs) # delay render
library(shinyBS) # tipify
library(plotly)
library(dplyr)
library(DT) # replaces functions from library(shiny)
library(magrittr)
library(stringr)
library(lubridate)
library(purrr)
library(XML)
library(curl)
# notin function ####
"%notin%" <- function(x,y)!("%in%"(x,y))
# function to simplify column names
autosnake <- function(df){ # to use in pipe
names(df) <- names(df) %>%
iconv(to="ASCII//TRANSLIT") %>% # remove accents
str_replace_na() %>% # convert NA to string
str_to_lower() %>% # convert to lower case
str_replace_all(pattern="%", replacement="pc") %>% # convert % to pc
str_replace_all(pattern="[^[:alnum:]]", replacement=" ") %>% # convert remaining non-alphanumeric to space
str_trim() %>% # trim leading and trailing spaces
str_replace_all(pattern="\\s+", replacement="_") # convert remaining spaces to underscore
df
}
# set up
ev_vars <- c("fat", "protein", "milk", "liveweight", "residual_survival",
"somatic_cell", "fertility", "body_condition_score")
ev_min_amer <- c("fat"=0, "protein"=00, "milk"=-0.15, "liveweight"=-2, "residual_survival"=0.0,
"somatic_cell"=-100, "fertility"=03, "body_condition_score"=000)
ev_max_amer <- c("fat"=7, "protein"=10, "milk"=+0.60, "liveweight"=+1, "residual_survival"=0.5,
"somatic_cell"=+000, "fertility"=20, "body_condition_score"=300)
ev_step_amer <- c("fat"=0.1, "protein"=0.1, "milk"=0.01, "liveweight"=0.1, "residual_survival"=0.01,
"somatic_cell"=1, "fertility"=0.1, "body_condition_score"=1)
# (ev_max_amer-ev_min_amer)/ev_step_amer
ev_names <- c("Milk Fat ($/kg)", "Milk Protein ($/kg)", "Milk Volume ($/L)", "Live Weight ($/kg)",
"Residual Survival ($/day)", "Somatic Cell Count ($/SCS)", "Fertility ($/CR42)",
"Body Condition Score ($/unit)")
ev_description <- c("BW per kg milk fat",
"BW per kg milk protein",
"BW per kg of milk volume",
"BW per kg of live weight",
"BW per day of residual survival",
"BW per unit of SCS",
"BW per unit of CR42",
"BW per unit of BCS") # FIXME
bv_vars <- c(ev_vars, "udder_overall", "dairy_conformation")
bv_names <- c("Milk Fat", "Milk Protein", "Milk Volume", "Live Weight",
"Residual Survival", "Somatic Cell Count", "Fertility",
"Body Condition Score", "Udder Overall", "Dairy Conformation")
bv_abbrev <- c("Fat", "Prot", "Vol", "LW",
"Surv", "SCC", "Fert",
"BCS", "Udder", "Conf")
bv_units <- c("kg", "kg", "L", "kg",
"days", "SCS", "CR42",
"units", "units", "units")
bv_breeds <- c("Friesian", "Jersey", "Cross", "Ayrshire", "Other")
alltext <- "All Breeds"
bv_breeds_all <- as.list(c(bv_breeds, alltext))
rastext <- "RAS Only"
# read bv function
read_bv <- function(){
cat("read bull data... \n")
if (isRunning()){
showNotification("Reading Bull data...")
}
bv_file_csv_all <- list.files(pattern="^bw-bull-file-[0-9]{8}.csv$", ignore.case=TRUE)
bv_file_rds_all <- list.files(pattern="^bw-bull-file-[0-9]{8}.rds$", ignore.case=TRUE)
bv_file_csv <- max(bv_file_csv_all) # latest version
bv_file_rds <- str_replace(bv_file_csv, "csv$", "rds")
read_from_website <- TRUE
force_read_csv <- TRUE
if (read_from_website){
cat("...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)
endstr <- function(x, n){substr(x, nchar(x)-n+1, nchar(x))}
numerify_factor <- function(f){as.numeric(as.character(f))}
web_vars <- setNames(c(1:10, 64, 65),
c("name", "bw_rel", ev_vars[c(2,1,3,4,7,6,5,8)], "udder_overall", "dairy_conformation"))
web_names <- names(web_vars)[3:12]
i <- 1
for (i in 1:4){
j <- c(6,11,16,21)[i]
bv[[i]] <- tibble::as_tibble(temp[[j]]) %>%
dplyr::select(web_vars) %>%
magrittr::set_colnames(names(web_vars)) %>%
dplyr::mutate(breed=bv_breeds[i],
breedcode=endstr(as.character(temp[[j+1]][[2]]),3), # breed code is in next table
ras=TRUE
)
}
bv <- suppressWarnings(dplyr::bind_rows(bv)) # converts factors to character
bv <- bv %>%
dplyr::mutate_at(web_names, numerify_factor) %>%
dplyr::mutate_at(names(web_vars)[1:2], as.character) %>%
dplyr::rename(breed_string=breedcode,
breed_cat=breed,
ras_flag=ras)
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]])
for (i in 1:8){
j <-paste0(ev_vars[i], "_ev")
bv[[j]] <- numerify_factor(ev[[3]])[i]
}
} else if (bv_file_rds %in% bv_file_rds_all && !force_read_csv){
cat("...from rds\n")
bv <- readRDS(bv_file_rds)
} else {
if (isRunning()){
showNotification("Compressing Bull data...")
}
cat("...from csv\n")
bv <- suppressMessages(readr::read_csv(bv_file_csv, guess_max=10000)) %>% autosnake()
bv <- bv %>%
mutate(
active_flag = as.logical(active_flag),
ras_flag = as.logical(ras_flag)
) %>%
filter(active_flag)
# View(bv)
# sort(names(bv))[str_detect(names(bv), "_bv")]
names(bv) <- str_replace(names(bv), "_bv", "")
# names(bv)[duplicated(names(bv))]
bv <- bv %>%
mutate(
breed_cat=factor(breed_cat, levels=bv_breeds),
dob=ymd(date_of_birth), # parse dob
yob=year(dob),
country_of_birth=factor(country_of_birth),
# breed_string=case_when(
# is.na(breed_2) ~ str_c(breed_1, "-", breed_1_16ths),
# TRUE ~ str_c(breed_1, "-", breed_1_16ths, "+", breed_2, "-", breed_2_16ths)
# )
# breed_string=case_when(
# is.na(breed_2) ~ str_c(str_sub(breed_1,1), breed_1_16ths),
# TRUE ~ str_c(str_sub(breed_1,1), breed_1_16ths, str_sub(breed_2,1), breed_2_16ths)
# )
breed_string=breed_1
)
bv <- bv %>%
dplyr::select(breed_cat, breed_string, yob, country_of_birth, name,
breeding_worth, ras_flag,
fat, fat_reliability, fat_ev,
protein, protein_reliability, protein_ev,
milk, milk_reliability, milk_ev,
liveweight, liveweight_reliability, liveweight_ev,
residual_survival, residual_survival_reliability, residual_survival_ev,
somatic_cell, somatic_cell_reliability, somatic_cell_ev,
fertility, fertility_reliability, fertility_ev,
body_condition_score, body_condition_score_reliability, body_condition_score_ev,
udder_overall, dairy_conformation
) %>%
tidyr::drop_na()
# summary(bv)
# write data
saveRDS(bv, file=bv_file_rds)
}
bv <- bv %>%
dplyr::rename(
bull=name,
breed=breed_cat,
ras=ras_flag
) %>%
dplyr::mutate(
row = 1:n(),
bulltext = paste0("<b>",bull,"</b>"),
breedtext = paste0("<b>",str_sub(breed_string,1,3),"</b>")
)
ev <- tibble(trait = ev_names) %>%
mutate(
ev_val = as.matrix(bv[1, paste0(ev_vars, "_ev")])[1,],
ev_var = ev_vars,
ev_min = signif(pmin(ev_val, ev_min_amer[ev_vars]), 2),
ev_max = signif(pmax(ev_val, ev_max_amer[ev_vars]), 2),
ev_step = ev_step_amer[ev_vars] # bigger steps look better
)
return(list(bv=bv, ev=ev))
}
# calculate BW for bv using matrix mult
calc_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)
}
# some constants
topn <- 10 # coloured blue
shown <- 20 # extent of graph
bluetext <- paste("Top", topn)
greentext <- "Other"
# graph range function
lmargin <- 80
rmargin <- 80
nwidth <- 200 # name
bwidth <- 50 # breed
calc_range <- function(xrange, plotpixels=450){
axispixels <- plotpixels - lmargin - rmargin # plot margins
xrangepixels <- axispixels - nwidth - bwidth # space needed for bull and breed name text
xrange + (max(xrange) - min(xrange)) / xrangepixels * c(-nwidth, bwidth)
}
# some colours
zzblack <- "black"
zzwhite <- "white"
zzslate <- "#353735"
zzlightslate <- "#b5c2bc" # https://www.color-hex.com/color-palette/18977
zzpaleslate <- "#f4f3f3" # https://www.color-hex.com/color-palette/18977
zzmidslate <- "#c0c2c0"
zzgreen <- "#69BE28"
zzlightgreen <- "#74ff8b" # https://www.color-hex.com/color-palette/77235
zzpalegreen <- "#abffad" # https://www.color-hex.com/color-palette/77235
zzmidgreen <- "#a5d77e"
zzblue <- "#009AA6"
zzlightblue <- "#94d1e4" # https://www.color-hex.com/color-palette/76824
zzpaleblue <- "#bee3ee" # https://www.color-hex.com/color-palette/76824
zzmidblue <- "#6dc9d0"
zzred <- "#ff0000" # https://www.color-hex.com/color-palette/76991
zzdarkred <- "#b30033" # https://www.color-hex.com/color-palette/76991
if (FALSE){
scales::show_col(c(zzslate, zzlightslate, zzpaleslate, zzmidslate,
zzgreen, zzlightgreen, zzpalegreen, zzmidgreen,
zzblue, zzlightblue, zzpaleblue, zzmidblue,
zzred, zzdarkred))
}
#### ui ####
# https://gist.github.com/guybowden/90f42413649148df7632
sliderstyle <- gsub("#000069", zzblue,
".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(
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(4,
strong("Economic Values", style="font-size: 14px;"),
br(""),
tags$style(HTML(sliderstyle)),
lapply(1:8, function(i){
uiOutput(paste0("slider", i))
})
),
column(8,
align="left",
uiOutput("radio1"),
uiOutput("check1"),
strong("Bull Rank:", style="font-size: 14px"),
plotlyOutput("bull_plot", height="auto")
)
),
fluidRow(
align="left",
strong("Average Breeding Values:", style="font-size: 14px"),
dataTableOutput("avtable", width="100%")
),
fluidRow(
align="right",
em(version)
)
) # fluidPage
#### server ####
# this code is run once when a user visits the app
server <- function(input, output, session){
cat("run server function\n")
# load data ####
temp <- read_bv()
evin <- temp$ev # ev df
bvin <- temp$bv # bv df
# slider controls ####
evorig <- reactiveVal(evin$ev_val) # original ev values
evuser <- reactiveVal() # user defined ev values
evcalc <- reactiveVal() # ev values used for plot
# https://www.w3schools.com/css/default.asp
cat("create sliders\n")
lapply(1:8, function(i){
output[[paste0("slider", i)]] <- renderUI({
cat("render sliderInput\n")
sliderInput(paste0("ev",i),
strong(evin$trait[i], style="line-height: 0.0; font-size: 14px"),
evin$ev_min[i],
evin$ev_max[i],
evin$ev_val[i],
evin$ev_step[i]
)
})
})
# display radio buttons ####
output$radio1 <- renderUI({
cat("render radioButtons\n")
tipify(
radioButtons("radio",
strong("Display:", style="font-size: 14px"),
choices=list("Current EV"=1, "Slider EV"=2, "Reset Sliders"=3),
selected=2,
inline=TRUE),
title="Select EV to use for BW calculation and ranking."
)
})
# update evuser() and possibly evcalc() from sliders
observeEvent({
input$ev1
input$ev2
input$ev3
input$ev4
input$ev5
input$ev6
input$ev7
input$ev8
}, {
req(input$radio)
evuser(c(input$ev1, input$ev2, input$ev3, input$ev4,
input$ev5, input$ev6, input$ev7, input$ev8))
cat("\nnew evuser() <- ", paste(evuser()), "\n")
if (input$radio==2){
evcalc(evuser())
cat("new evcalc() <- ", paste(evcalc()), "\n")
}
})
# respond to radio buttons
observeEvent(input$radio, {
cat("observed radio button\n")
cat("input$radio = ", input$radio, "\n")
if (input$radio %in% 3){ # reset sliders
updateRadioButtons(session, "radio", selected=2)
cat("revert to evorig() <- ", paste(evorig()), "\n")
for (i in 1:8){
updateSliderInput(session, paste0("slider",i), value=evorig()[i])
}
evuser(evorig())
evcalc(evorig())
} else if (input$radio %in% 2){ # show user ev
evcalc(evuser())
} else { # show original ev
evcalc(evorig())
}
})
# filter checkbox ####
checkstate <- reactiveVal(c(bv_breeds, alltext, rastext)) # state of checkboxes
output$check1 <- renderUI({
cat("render checkboxGroupInput\n")
tipify(
checkboxGroupInput("check",
strong("Filter:", style="font-size: 14px"),
choices=isolate(checkstate()),
selected=isolate(checkstate()),
inline=TRUE),
title="Select breed and RAS status to include."
)
})
observeEvent(input$check, ignoreNULL=FALSE, {
# note: this is all isolated
req(input$check)
cat("observed checkbox\n")
cat("old checkstate() = ", paste(checkstate()), "\n")
cat("new input$check = ", paste(input$check), "\n")
set <- max(setdiff(input$check, checkstate()), "")
unset <- max(setdiff(checkstate(), input$check), "")
if (print(set %in% alltext)){
# rule 1 - setting All sets all breeds
newstate <- union(input$check, bv_breeds)
} else if (print(!any(bv_breeds %in% input$check))){
# rule 2 - can't unset last breed
newstate <- checkstate()
} else if (print(unset %in% alltext)){
# rule 3 - unsetting All does nothing
newstate <- checkstate()
} else if (print(unset %in% bv_breeds)){
# rule 4 - unsetting any breed unsets All
newstate <- setdiff(input$check, alltext)
} else if (print(all(bv_breeds %in% input$check) && alltext %notin% input$check)){
# rule 5 - setting the last breed sets All
newstate <- union(input$check, alltext)
} else if (print(TRUE)){
# accept change as is
newstate <- input$check
}
# update checkstate() and checkboxes
if (!setequal(checkstate(), newstate)){
checkstate(newstate)
}
updateCheckboxGroupInput(session, "check", selected=newstate)
})
#### calculations ####
my <- reactiveValues( # additional data for bvin
# my <- list( # for testing
f = 0, # frame number
speed = 500, # animation speed (ms)
evcalc = evin$ev_val, # ev used for current calc
checkstate = NA, # checkbox options used for current calc
bwm = NA, # current BW
bwr = NA, # current rank
x = NA, # current x position
y = -1, # current y position
isblue = FALSE, # is this a topn bull?
prevx = NA,
prevy = NA,
previsblue = NA,
f = 0, # frame number
d = NA, # plot dataframe
a = NA, # plot list
xrange = NA, # current plot xrange
xmin = NA, # left hand end of bars
xname = 5, # spacing for text FIXME should scale
yrange = c(1-0.5, shown+0.5),
yticks = as.list(seq(0,shown+1)),
ylabels = as.list(paste0(c("", seq(shown,1), ""), " "))
)
observeEvent({
checkstate()
evcalc()
} , {
my$f <- my$f + 1
cat("my$f = ", my$f, "\n")
cat("evcalc() =", paste(evcalc()), "\n")
cat("calc bull bw and rank\n")
i <- bvin$breed %in% checkstate()
j <- bvin$ras | rastext %notin% checkstate()
my$bwm <- calc_bwm(bvin, ev_vars, evcalc())
my$bwr <- as.numeric(rank(if_else(i & j, -my$bwm, -(my$bwm-1000)), ties.method="first"))
my$prevx <- my$x
my$prevy <- my$y
my$previsblue <- my$isblue
my$x <- my$bwm
my$y <- if_else(my$bwr <= shown, shown-my$bwr+1, -my$bwr/100)
if (!setequal(checkstate(), my$checkstate)){
# new colours
cat("new colours\n")
my$isblue <- (my$bwr <= topn)
}
my$evcalc <- evcalc()
my$checkstate <- checkstate()
my$xrange <- range(my$x)
my$xmin <- my$xrange[1] - 100
cat("calc data table\n")
round_me <- function(v){signif(v, 3)}
av <- colMeans(bvin[my$y>0, bv_vars]) %>%
as.list() %>%
as.data.frame() %>%
set_colnames(bv_abbrev) %>%
mutate_all(round_me) %>%
mutate_all(as.character)
print(av)
if (my$f==1){
av <- bind_rows(av, av, setNames(bv_units, bv_abbrev)) %>%
set_rownames(c("Current EV", "Slider EV", "Units"))
} else {
av <- bind_rows(avbv()[1,], av, avbv()[3,]) %>%
set_rownames(c("Current EV", "Slider EV", "Units"))
}
avbv(av) # send data to DT
cat("calc plot dataframe\n")
if (my$f==1){
cat("initial ranks\n")
my$isblue <- (my$bwr <= topn) # initial blues
i <- which(my$bwr <= shown * 2) # initial bars
j <- seq(shown * 2)
my$d <- bvin[i, ] %>%
dplyr::select(bulltext, breedtext, row) %>%
dplyr::mutate(x=my$x[i], y=my$y[i], isblue=my$isblue[i], index=j)
# print(my$d, n=shown*2)
# View(my$d)
print(my$d$row)
} else {
# add new bulls to plot if needed (below x axis)
i <- my$d$row # bvin rows currently in my$d
j <- which(my$prevy[i]<0 & my$y[i]<0) # my$d slots available to discard
k <- setdiff(which(my$y>0), i) # bvin rows to add to my$d
cat("adding", length(k), "bulls\n")
if (length(k)>0){
stopifnot(length(j)>=length(k))
j <- head(j, length(k)) # only take first length(k) slots
my$d[j, ] <- bvin[k, ] %>%
dplyr::select(bulltext, breedtext, row) %>%
dplyr::mutate(x=my$prevx[k], y=my$prevy[k], isblue=my$previsblue[k], index=j)
# print(my$d, n=shown*2)
cat("FIXME need to add new rows into plot\n")
}
# new plot data
cat("new ranks\n")
i <- my$d$row # rows now in plot
my$d <- my$d %>%
dplyr::mutate(x=my$x[i], y=my$y[i])
# print(my$d, n=shown*2)
print(my$d$row)
}
cat("calc plot list\n")
pl <- plist()
if (my$f==1){
# blue legend trace
pl[[1]] <- list(x=c(my$xmin, my$xmin),
y=c(-1, -1),
# frame=my$f, # interferes with trace name
ids=paste0("blue", letters[1:2]),
name=bluetext,
type="scatter",
line=list(width=20, simplify=FALSE),
opacity=1,
color=I(zzblue),
mode="lines",
showlegend=TRUE,
hoverinfo="none")
# green legend trace
pl[[2]] <- list(x=c(my$xmin, my$xmin),
y=c(-1, -1),
# frame=my$f, # interferes with trace name
ids=paste0("green", letters[1:2]),
name=greentext,
type="scatter",
line=list(width=20, simplify=FALSE),
opacity=1,
color=I(zzgreen),
mode="lines",
showlegend=TRUE,
hoverinfo="none")
}
# green bars
bars <- my$d %>%
mutate(x=my$xmin, bulltext="", breedtext="") %>%
bind_rows(., my$d, .) %>%
arrange(index) %>%
mutate(id=paste0(index, rep_len(c("a","b","c"), n())))
# print(bars, n=shown*2)
pl[[3]] <- list(x=bars$x,
y=bars$y,
frame=my$f,
ids=bars$id,
type="scatter",
line=list(width=20, simplify=FALSE),
opacity=1,
mode="lines",
showlegend=FALSE,
hoverinfo="x")
if (my$f==1){
pl[[3]]$color <- I(zzgreen)
} else {
pl[[3]]$line$color <- I(zzgreen)
}
# blue bars
pl[[4]] <- list(x=if_else(bars$isblue, bars$x, my$xmin),
y=bars$y,
frame=my$f,
ids=bars$id,
type="scatter",
line=list(width=20, simplify=FALSE),
opacity=1,
mode="lines",
showlegend=FALSE,
hoverinfo="x")
if (my$f==1){
pl[[4]]$color <- I(zzblue)
} else {
pl[[4]]$line$color <- I(zzblue)
}
# bull names
pl[[5]] <- list(x=my$d$x-my$xname,
y=my$d$y,
frame=my$f,
ids=as.character(my$d$index),
text=my$d$bulltext,
textposition="middle left",
type="scatter",
color=I(zzwhite),
textfont=list(),
mode="text",
showlegend=FALSE,
hoverinfo="none")
# breed codes
pl[[6]] <- list(x=my$d$x+my$xname,
y=my$d$y,
frame=my$f,
ids=as.character(my$d$index),
text=my$d$breedtext,
textposition="middle right",
type="scatter",
color=I(zzmidslate),
textfont=list(),
mode="text",
showlegend=FALSE,
hoverinfo="none")
plist(pl) # send to plot
cat("calc done\n")
})
#### plot ####
plist <- reactiveVal(vector("list", 6)) # list for plot
output$bull_plot <- renderPlotly({
req(my$f==1)
cat("initial renderPlotly\n")
# https://stackoverflow.com/questions/39019212/suppress-plotly-warnings-in-shiny-app
store_warn <- getOption("warn")
options(warn=-1)
isolate({
# base plot
p <- plot_ly(height=700, margin=list(autoexpand=FALSE))
# make traces from data
pl <- plist()
p <- do.call(add_trace, prepend(pl[[1]], list(p))) # blue legend 0
p <- do.call(add_trace, prepend(pl[[2]], list(p))) # green legend 1
p <- do.call(add_trace, prepend(pl[[3]], list(p))) # green bars 2
p <- do.call(add_trace, prepend(pl[[4]], list(p))) # blue bars 3
p <- do.call(add_trace, prepend(pl[[5]], list(p))) # bull names 4
p <- do.call(add_trace, prepend(pl[[6]], list(p))) # breed codes 5
# add layout
temp <- list(xaxis=list(range=my$xrange,
title=list(text="<b>BW</b>"),
tickprefix="$",
zeroline=FALSE,
type="linear",
fixedrange=TRUE),
yaxis=list(range=my$yrange,
title=list(text="<b>Rank</b>"),
zeroline=FALSE,
tickmode="array",
tickvals=my$yticks,
ticktext=my$ylabels,
type="linear",
fixedrange=TRUE),
legend=list(orientation="h",
x=0.1,
y=1.06)
)
p <- do.call(layout, prepend(temp, list(p)))
p <- do.call(animation_opts, list(p, frame=my$speed, redraw=FALSE, mode="next"))
}) # isolate
# restore warnings, delayed so plot is completed
shinyjs::delay(100, options(warn=store_warn))
p
}) # renderPlotly
bull_plot_proxy <- plotlyProxy("bull_plot", session=session)
observeEvent(plist(), {
req(my$f>1)
cat("update plot\n")
pl <- plist()
plotlyProxyInvoke(bull_plot_proxy, "animate",
# frameOrGroupNameOrFrameList
list(
name = as.character(my$f),
data = pl[3:6],
traces = as.list(as.integer(2:5)),
layout = list()
),
# animationAttributes
list(
frame = list(duration=my$speed),
transition = list(duration=my$speed)
)
)# plotlyProxyInvoke
})
#### data table ####
avbv <- reactiveVal() # table of average bv values for DT
output$avtable <- renderDataTable({
req(my$f==1)
cat("initial renderDataTable\n")
datatable(
avbv(),
options = list(lengthChange=FALSE, ordering=FALSE, searching=FALSE,
columnDefs=list(list(className='dt-center', targets="_all")),
stateSave=TRUE, scrollX=FALSE, paging=FALSE, info=FALSE),
class = "nowrap cell-border hover stripe compact",
selection = "none",
rownames = TRUE,
editable = FALSE,
escape = FALSE
)
})
avtable_proxy <- dataTableProxy("avtable")
observeEvent(avbv(),{
req(my$f>1)
cat("update avtable\n")
# add html decoration, colours and arrows (not needed on initial render)
# https://stackoverflow.com/questions/42569302/format-color-of-shiny-datatable-dt-according-to-values-in-a-different-dataset
av <- avbv()
av[2, 1:ncol(av)] <- mapply(function(i, j, k){
case_when(
as.numeric(i)>as.numeric(j) & k>0 ~ paste0("<span style='color:red'>",j,"<font>⇓ </font></span>"),
as.numeric(i)<as.numeric(j) & k>0 ~ paste0("<span style='color:green'>",j,"<font>⇑ </font></span>"),
as.numeric(i)<as.numeric(j) & k==0 ~ paste0("<span style='color:brown'>",j,"<font>⇑ </font></span>"),
as.numeric(i)>as.numeric(j) & k==0 ~ paste0("<span style='color:brown'>",j,"<font>⇓ </font></span>"),
as.numeric(i)<as.numeric(j) & k<0 ~ paste0("<span style='color:red'>",j,"<font>⇑ </font></span>"),
as.numeric(i)>as.numeric(j) & k<0 ~ paste0("<span style='color:green'>",j,"<font>⇓ </font></span>"),
TRUE ~ paste0("<span style='color:blue'>",j,"</span>")
)}, av[1, 1:ncol(av)], av[2, 1:ncol(av)], c(1,1,0,0,1,-1,1,1,1,1))
replaceData(avtable_proxy, as.data.frame(av))
})
} # server
shinyApp(ui, server)