We Keep Coding

Change cell color after updated value, not overwritten by selection

Basically what I want is a combination of these two answered posts
Change backgorund color of cell of data table while its value is edited in Rshiny
Shiny with DT Select rows, keep cell color
so I want the cell color to change after each edit on the client side, but when the rows with an edited cell are selected, I need the selection highlight to not overwrite the cell colorization, (so that it looks like this https://i.stack.imgur.com/K2Gjv.png).
Difference between my problem and the one here
Shiny with DT Select rows, keep cell color
is that in my case the cell colors which need to keep their cell colors can not be hardocoded as they are selected by the client.
code which enables the cell colorization after cell edit (code from #StéphaneLaurent (I only changed a minor thing so that now selections are possible)), however here the selection "overwrites" the yellow cells. Is it even possible to achieve what I want?
library(shiny)
library(shinyjs)
library(DT)
js <- HTML(
"function colorizeCell(i, j){
var selector = '#dtable tr:nth-child(' + i + ') td:nth-child(' + j + ')';
$(selector).css({'background-color': 'yellow'});
}"
)
colorizeCell <- function(i, j){
sprintf("colorizeCell(%d, %d)", i, j)
}
ui <- fluidPage(
useShinyjs(),
tags$head(
tags$script(js)
),
br(),
DTOutput("dtable")
)
dat <- iris[1:5, ]
server <- function(input, output, session){
output[["dtable"]] <- renderDT({
datatable(dat, editable = TRUE)
}, server = FALSE)
observeEvent(input[["dtable_cell_edit"]], {
info <- input[["dtable_cell_edit"]]
i <- info[["row"]]
j <- info[["col"]]
runjs(colorizeCell(i, j+1))
})
}
shinyApp(ui, server)

library(shiny)
library(shinyjs)
library(DT)
css <- HTML(
"table.dataTable tr.selected td.yellow {
background-color: yellow !important
}
td.yellow {
background-color: yellow !important
}"
)
js <- HTML(
"function colorizeCell(i, j){
var selector = '#dtable tr:nth-child(' + i + ') td:nth-child(' + j + ')';
$(selector).addClass('yellow');
}"
)
colorizeCell <- function(i, j){
sprintf("colorizeCell(%d, %d)", i, j)
}
ui <- fluidPage(
useShinyjs(),
tags$head(
tags$style(css),
tags$script(js)
),
br(),
DTOutput("dtable")
)
dat <- iris[1:5, ]
server <- function(input, output, session){
output[["dtable"]] <- renderDT({
datatable(dat, editable = TRUE)
}, server = FALSE)
observeEvent(input[["dtable_cell_edit"]], {
info <- input[["dtable_cell_edit"]]
i <- info[["row"]]
j <- info[["col"]]
runjs(colorizeCell(i, j+1))
})
}
shinyApp(ui, server)

R shiny DT hover shows detailed table

I am trying to work on an R shiny app where I want to show a consolidated table on top and when the user hovers on any line item it would show the detailed section of that table.So here's the code for the first table
library(ggplot2)
ui <- fluidPage(
titlePanel("Basic DataTable"),
# Create a new row for the table.
DT::dataTableOutput("table")
)
server <- function(input, output) {
data <- mpg
data <-data %>% group_by(manufacturer,year) %>%
summarise(cty = round(mean(cty),2),hwy = round(2,mean(hwy)))
# Filter data based on selections
output$table <- DT::renderDataTable(DT::datatable({
data
}))
}
shinyApp(ui,server)
Now when the user hovers on Audi for example it should show a detailed version just forAudi something like this in a table below.Can this be done in shiny with DT on hover or click.

Here is a way. If you prefer to display the child table on click rather than on hover, replace "table.on('mouseover', 'td', function(){" with "table.on('click', 'td', function(){".
library(shiny)
library(DT)
data(mpg, package = "ggplot2")
callback <- c(
"table.on('mouseover', 'td', function(){",
" var index = table.cell(this).index();",
" Shiny.setInputValue('cell', index, {priority: 'event'});",
"});"
)
ui <- fluidPage(
br(),
DTOutput("tbl")
)
server <- function(input, output, session){
dat <- mpg
output[["tbl"]] <- renderDT({
datatable(
dat,
callback = JS(callback)
)
})
filteredData <- eventReactive(input[["cell"]], {
i <- input[["cell"]]$row + 1
j <- input[["cell"]]$column
if(j > 0){
dat[dat[[j]] == dat[i,j], , drop = FALSE]
}else{
NULL
}
})
output[["tblfiltered"]] <- renderDT({
datatable(
filteredData(),
fillContainer = TRUE,
options = list(
pageLength = 5
)
)
})
observeEvent(filteredData(), {
showModal(
modalDialog(
DTOutput("tblfiltered"),
size = "l",
easyClose = TRUE
)
)
})
}
shinyApp(ui, server)

The select drop down menu appear behind other elements in shiny

Can any one give me a solution to the following issue where the drop down goes under the plotly hover when going to select the fist item in the drop down.
I used the following code. But didn't work.
in UI,
fluidRow(
tags$hr(style="z-index: 10000;"),
column(width = 3,h2("Device Type")),
column(width = 3,htmlOutput("disselect")),
column(width = 3,htmlOutput("cityeselect")),
column(width = 3,h2("Property Type"))
),
in server
output$disselect <- renderUI({
selectInput("district", "District", c("All",unique(bookings$District)), selected = "All")
})
Any hacks?

Set the z-index of the drop-down so that it's greater than that of the plotly modebar, for instance 1002 would work:
column(width = 3, offset = 9,
selectInput("y", "y", colnames(mtcars)),style="z-index:1002;")
A working example:
library(shiny)
library(plotly)
ui <- fluidPage(
fluidRow(
column(width = 3, offset = 9,
selectInput("y", "y", colnames(mtcars)),style="z-index:1002;")
),
fluidRow(plotlyOutput("plot"))
)
server <- function(input, output, session) {
output$plot <- renderPlotly({
g <- ggplot(mtcars, aes_string("disp", input$y)) +
geom_point()
g <- ggplotly(g) %>%
config(displayModeBar = TRUE)
g
})
}
shinyApp(ui, server)

If you don't need the plotly modebar, you can just remove it.
Here's an example:
library(shiny)
library(plotly)
ui <- fluidPage(
fluidRow(
column(width = 3, offset = 9,
selectInput("y", "y", colnames(mtcars)))
),
fluidRow(plotlyOutput("plot"))
)
server <- function(input, output, session) {
output$plot <- renderPlotly({
g <- ggplot(mtcars, aes_string("disp", input$y)) +
geom_point()
### code to hide the modebar ###
g <- ggplotly(g) %>%
config(displayModeBar = FALSE)
g
})
}
shinyApp(ui, server)

R Shiny Dynamic text in header (reactive renderUI)

I am trying to put dynamic text in shiny's header, and have managed to put text in it, but cannot get it to update after it has received new data from an reactive expression. To put text in the header, I have used a basic Java call, tags$script.
My concern is that renderUI only renders the 1st time, and does not force render whenever the reactive value (val) is updated, which is exactly what I require.
Apologies for the weird example below, I have a HUGE dashboard which has several chained dependencies, and I have tried to replicate the types of dependencies in the reproducible example below.
library(shiny)
library(shinydashboard)
ui <- fluidPage(
dashboardPage(skin = 'black',
dashboardHeader(title = "test"),
dashboardSidebar(
sidebarMenu(id = 'MenuTabs',
menuItem("dummy", tabName = "rawanalysis", selected = TRUE, icon = icon("dashboard"))
)
),
dashboardBody(
uiOutput(outputId = 'Header'),
fluidRow(
box(
actionButton("change", "Change")
)
))))
server <- function(input, output) {
Go_rv <- reactiveValues(val = 0)
observeEvent(input$change, {
sam <- rnorm(1)
if(sam > 0){
Go_rv$val <- TRUE
} else {
Go_rv$val <- FALSE
}
})
val <- reactive({
print(Go_rv$val)
if(Go_rv$val){
out <- 0
} else {
out <- -5
}
return(out)
})
output$Header <- renderUI({
removeUI(
selector = "div:has(> #Header)"
)
header_text <- paste0('$(document).ready(function() {
$("header").find("nav").append(\'<div class="myClass">', val(), '</div>\');})')
tags$script(HTML(header_text),
id = 'Header'
)
})
}
shinyApp(ui = ui, server = server)

Basically, a reactive text output with observeEvent should do this job!
library(shiny)
library(shinydashboard)
ui <- fluidPage(
dashboardPage(skin = 'black',
dashboardHeader(title = textOutput('test')),
dashboardSidebar(
sidebarMenu(id = 'MenuTabs',
menuItem("dummy", tabName = "rawanalysis", selected = TRUE, icon = icon("dashboard"))
)
),
dashboardBody(
#uiOutput(outputId = 'Header'),
fluidRow(
box(
actionButton("change", "Change")
)
))))
server <- function(input, output,session) {
title_change <- reactive({
input$change
as.character(Sys.time())
})
observeEvent(input$change, { output$test <- renderText({ title_change()
})
})
}
shinyApp(ui = ui, server = server)

R pull in html data with extra java reveal

I want to pull in data from 538, but I want the full data which is arrived at by clicking on "Show more polls"... Is there any way for the function to access the additional lines of the table?
http://projects.fivethirtyeight.com/2016-election-forecast/national-polls/
The code for pulling in the top level data is:
require(XML)
polls.html <- htmlTreeParse("http://projects.fivethirtyeight.com/2016-election-forecast/national-polls/",
useInternalNodes = TRUE)
parsedDoc <- readHTMLTable(polls.html, stringsAsFactors=FALSE)
pollData <- data.frame(parsedDoc[4])

I'm a little confused as to why this got downvoted... still doesn't seem obvious to me! But for anyone who wants to know the solution, I did figure it out (thanks to some help from #duncantl). (Also, the complete analysis is at: https://github.com/hardin47/prediction2016)
require(XML)
require(dplyr)
require(tidyr)
require(readr)
require(mosaic)
require(RCurl)
require(ggplot2)
require(lubridate)
require(RJSONIO)
url = "http://projects.fivethirtyeight.com/2016-election-forecast/national-polls/"
doc <- htmlParse(url, useInternalNodes = TRUE)
sc = xpathSApply(doc, "//script[contains(., 'race.model')]",
function(x) c(xmlValue(x), xmlAttrs(x)[["href"]]))
jsobj = gsub(".*race.stateData = (.*);race.pathPrefix.*", "\\1", sc)
data = fromJSON(jsobj)
allpolls <- data$polls
#unlisting the whole thing
indx <- sapply(allpolls, length)
pollsdf <- as.data.frame(do.call(rbind, lapply(allpolls, `length<-`, max(indx))))
#unlisting the weights
pollswt <- as.data.frame(t(as.data.frame(do.call(cbind, lapply(pollsdf$weight, data.frame,
stringsAsFactors=FALSE)))))
names(pollswt) <- c("wtpolls", "wtplus", "wtnow")
row.names(pollswt) <- NULL
pollsdf <- cbind(pollsdf, pollswt)
#unlisting the voting
indxv <- sapply(pollsdf$votingAnswers, length)
pollsvot <- as.data.frame(do.call(rbind, lapply(pollsdf$votingAnswers,
`length<-`, max(indxv))))
pollsvot1 <- rbind(as.data.frame(do.call(rbind, lapply(pollsvot$V1, data.frame,
stringsAsFactors=FALSE))))
pollsvot2 <- rbind(as.data.frame(do.call(rbind, lapply(pollsvot$V2, data.frame,
stringsAsFactors=FALSE))))
pollsvot1 <- cbind(polltype = rownames(pollsvot1), pollsvot1,
polltypeA = gsub('[0-9]+', '', rownames(pollsvot1)),
polltype1 = extract_numeric(rownames(pollsvot1)))
pollsvot1$polltype1 <- ifelse(is.na(pollsvot1$polltype1), 1, pollsvot1$polltype1 + 1)
pollsvot2 <- cbind(polltype = rownames(pollsvot2), pollsvot2,
polltypeA = gsub('[0-9]+', '', rownames(pollsvot2)),
polltype1 = extract_numeric(rownames(pollsvot2)))
pollsvot2$polltype1 <- ifelse(is.na(pollsvot2$polltype1), 1, pollsvot2$polltype1 + 1)
pollsdf <- pollsdf %>%
mutate(population = unlist(population),
sampleSize = as.numeric(unlist(sampleSize)),
pollster = unlist(pollster),
startDate = ymd(unlist(startDate)),
endDate = ymd(unlist(endDate)),
pollsterRating = unlist(pollsterRating)) %>%
select(population, sampleSize, pollster, startDate, endDate, pollsterRating,
wtpolls, wtplus, wtnow)
allpolldata <- cbind(rbind(pollsdf[rep(seq_len(nrow(pollsdf)), each=3),],
pollsdf[rep(seq_len(nrow(pollsdf)), each=3),]),
rbind(pollsvot1, pollsvot2))
allpolldata <- allpolldata %>%
arrange(polltype1, choice)