Weird problem with plotly plot and DT data table both disappearing on update SOLVED!!!

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>&dArr; </font></span>"),
				as.numeric(i)<as.numeric(j) & k>0  ~ paste0("<span style='color:green'>",j,"<font>&uArr; </font></span>"),
				as.numeric(i)<as.numeric(j) & k==0 ~ paste0("<span style='color:brown'>",j,"<font>&uArr; </font></span>"),
				as.numeric(i)>as.numeric(j) & k==0 ~ paste0("<span style='color:brown'>",j,"<font>&dArr; </font></span>"),
				as.numeric(i)<as.numeric(j) & k<0  ~ paste0("<span style='color:red'>",j,"<font>&uArr; </font></span>"),
				as.numeric(i)>as.numeric(j) & k<0  ~ paste0("<span style='color:green'>",j,"<font>&dArr; </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)

Hi,

I found out what caused the issue:
You used the isolate function in your initial plot and it somehow interfered with the proxy update. Also, the req(my$f==1) in the initial plot and table should be removed.

You created that isolate to prevent an error in the prepend function on initialization of the plist variable I think, but you can't do that as the update of this function triggers the refreshing of the code. Instead I added this to the top: req(!is.null(plist()[[1]]))

I think all is working properly now, let me know if it is!

# 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(!is.null(plist()[[1]]))
    cat("initial renderPlotly\n")
    # https://stackoverflow.com/questions/39019212/suppress-plotly-warnings-in-shiny-app
    store_warn <- getOption("warn")
    options(warn=-1)
   
      # 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
  
  observeEvent(avbv(), {
    print(head(avbv()))
    print(my$f)
  })
  
  output$avtable <- renderDataTable({
    
    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")

  observe({
    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>&dArr; </font></span>"),
        as.numeric(i)<as.numeric(j) & k>0  ~ paste0("<span style='color:green'>",j,"<font>&uArr; </font></span>"),
        as.numeric(i)<as.numeric(j) & k==0 ~ paste0("<span style='color:brown'>",j,"<font>&uArr; </font></span>"),
        as.numeric(i)>as.numeric(j) & k==0 ~ paste0("<span style='color:brown'>",j,"<font>&dArr; </font></span>"),
        as.numeric(i)<as.numeric(j) & k<0  ~ paste0("<span style='color:red'>",j,"<font>&uArr; </font></span>"),
        as.numeric(i)>as.numeric(j) & k<0  ~ paste0("<span style='color:green'>",j,"<font>&dArr; </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), resetPaging = F)
  })
  
} # server

shinyApp(ui, server)

PJ

1 Like

Thanks so much for having a look at this Pieter! Unfortunately your solution rerenders the whole plot and table on each user input (you can see this in the console log), whereas I wanted to only render them once and then use proxy to update them subsequently. But you have given me a direction to look. I found if I comment out the last two observeEvent() it still doesn't work. So I know the problem is not those.

I think I need to render the datatable and plotly on the first pass through without using req(my$f==1). I might need to reorder the code a bit.

SOLVED!!! I just needed to remove the reactivity from renderPlotly and renderDataTable (to ensure they were evaluated only once), and move the declarations of avbv and plist to before the observeEvent where they were set. This ensured that avbv and plist were ready for the first and only time renderPlotly and renderDataTable were evaluated.

1 Like

This topic was automatically closed 7 days after the last reply. New replies are no longer allowed.