I'm currently designing a Shiny app that outputs a table. I would like to highlight the cells in a particular column (e.g., make the cells blue). I've tried using the HighlightRows function from the shinyBS package, but that doesn't seem to work.
Here is a portion of my server script making up the table:
output$text1 <- renderTable({
tab1 <- as.data.frame(matrix(c(rrround(input$patha,3),PowerF()$tta,input$nxn,rrround(currentInput()$patha,3),rrround(rxyval()$rxy,3),rrround(rxyval()$rxy_p,3),rround(PowerF()$tra,3),
rrround(input$pathp,3),PowerF()$ttp,input$nxn,rrround(currentInput()$pathp,3),rrround(rxyval()$rxyp,3),rrround(rxyval()$rxyp_p,3),rround(PowerF()$trp,3))
,ncol=7, byrow=TRUE))
rownames(tab1) <- c('Actor', 'Partner')
colnames(tab1) <- c('Size', 'Power', 'N','Beta','r','partial r','ncp')
tab1.align = "r"
highlightRows(session, id='tab1', class = "info", column="Power", regex = ".")
print(tab1, type="html")
})
Any help would be greatly appreciated.
Thanks!
You can modify your datatable using tags$script. below is an example of highlighting 3 columns (1), (5) and (9) of a sample datatable. I had a small problem with a similar issue, you can view that How to change Datatable row background colour based on the condition in a column, Rshiny
rm(list = ls())
library(shiny)
options(digits.secs=3)
test_table <- cbind(rep(as.character(Sys.time()),10),rep('a',10),rep('b',10),rep('b',10),rep('c',10),rep('c',10),rep('d',10),rep('d',10),rep('e',10),rep('e',10))
colnames(test_table) <- c("Time","Test","T3","T4","T5","T6","T7","T8","T9","T10")
ui =navbarPage(inverse=TRUE,title = "Coloring datatables",
tabPanel("Logs",icon = icon("bell"),
mainPanel(htmlOutput("logs"))),
tabPanel("Extra 2",icon = icon("bell")),
tabPanel("Extra 3",icon = icon("bell")),
tags$style(type="text/css", "#logs td:nth-child(1) {text-align:center;background-color:red;color: white;text-align:center}"),
tags$style(type="text/css", "#logs td:nth-child(5) {text-align:center;background-color:blue;color: white;text-align:center}"),
tags$style(type="text/css", "#logs td:nth-child(9) {text-align:center;background-color:green;color: white;text-align:center}")
)
server <- (function(input, output, session) {
my_test_table <- reactive({
other_data <- rbind(c(as.character(Sys.time()),(sample(c("Pass","Aggr","Bad"))[1]),round(c(rnorm(1),rnorm(1),rnorm(1),rnorm(1),rnorm(1),rnorm(1),rnorm(1),rnorm(1)),2)),
(c(as.character(Sys.time()),(sample(c("Pass","Aggr","Bad"))[1]),round(c(rnorm(1),rnorm(1),rnorm(1),rnorm(1),rnorm(1),rnorm(1),rnorm(1),rnorm(1)),2))))
test_table <<- rbind(apply(other_data, 2, rev),test_table)
as.data.frame(test_table)
})
output$logs <- renderTable({my_test_table()},include.rownames=FALSE)
})
runApp(list(ui = ui, server = server))
Related
I am trying filter my data using the dplyr package inside the reactive function in Shiny, but nothing is being displayed in the output. The data is supposed to be filtered by levels of the variable "Country".
Here is the code I have used and the dataframe
datos<-data.frame(time=c(rep(c(2001, 2002),3)), values=c(100,200,300,600,700,800), country=c(rep("Uruguay",2),rep("France",2),rep("United States",2)))
ui <- fluidPage(
selectInput(inputId ="pais", label="Choose a country",
choices =levels(datos$country), selected = "Uruguay"),
plotOutput(outputId ="barplot")
)
server <- function(input, output) {
datos3 <- reactive({
datos%>%
filter(country=="input$pais")
})
output$barplot<-renderPlot({
ggplot(datos3(),aes(x=time,y=values))+geom_bar(stat="Identity")
})
}
shinyApp(ui = ui, server = server)
I am supposed to obtain the values for the selected country, by time period.
You didn't need the quotation marks on "input$pais".
Here is the code with that and the extra + in the ggplot section removed.
library(shiny)
library(tidyverse)
datos<-data.frame(time=c(rep(c(2001, 2002),3)), values=c(100,200,300,600,700,800), country=c(rep("Uruguay",2),rep("France",2),rep("United States",2)))
ui <- fluidPage(
selectInput(inputId ="pais", label="Choose a country",
choices =levels(datos$country), selected = "Uruguay"),
plotOutput(outputId ="barplot")
)
server <- function(input, output) {
datos3 <- reactive({
datos%>%
filter(country==input$pais) #this bit has been changed
})
output$barplot<-renderPlot({
ggplot(datos3(),aes(x=time,y=values))+geom_bar(stat="Identity")
})
}
shinyApp(ui = ui, server = server)
I confess, I did post this question over on RStudio three days ago but it has not had enough love yet, so I'm trying again here. I hope that's okay. The original question is here (the text is the same in both, I'm just being transparent). https://community.rstudio.com/t/selecting-rows-from-a-dt-table-using-crosstalk-in-shiny/4079
So I would like to brush across points in D3Scatter and use it to filter the rows of a datatable produced using the DT package with crosstalk.
Just like this, which totally works outside of shiny:
library(crosstalk)
library(d3scatter)
library(DT)
shared_iris <- SharedData$new(iris)
bscols(d3scatter(shared_iris, ~Petal.Length, ~Petal.Width, ~Species, width = "100%",
x_lim = range(iris$Petal.Length), y_lim = range(iris$Petal.Width)),
datatable(shared_iris))
But when I put it in Shiny, I can select points on the scatter from the table, but not vice versa:
library(shiny)
library(crosstalk)
library(d3scatter)
library(DT)
ui <- fluidPage(
fluidRow(
column(6, d3scatterOutput("scatter1")),
column(6, DT::dataTableOutput("scatter2"))
)
)
server <- function(input, output, session) {
jittered_iris <- reactive({
iris
})
shared_iris <- SharedData$new(jittered_iris)
output$scatter1 <- renderD3scatter({
d3scatter(shared_iris, ~Petal.Length, ~Petal.Width, ~Species, width = "100%",
x_lim = range(iris$Petal.Length), y_lim = range(iris$Petal.Width))
})
output$scatter2 <- DT::renderDataTable({
datatable(shared_iris)
})
}
shinyApp(ui, server)
They’ve got it working here: https://rstudio-pubs-static.s3.amazonaws.com/215948_95c1ab86ad334d2f82856d9e5ebc16af.html
I’m at a loss. I feel like I’ve tried everything. Any clues anyone?
Thanks,
Crosstalk integration in DT only works with client-side processing . Try DT::renderDataTable with server = FALSE
library(shiny)
library(crosstalk)
library(d3scatter)
library(DT)
ui <- fluidPage(
fluidRow(
column(6, d3scatterOutput("scatter1")),
column(6, DT::dataTableOutput("scatter2"))
)
)
server <- function(input, output, session) {
jittered_iris <- reactive({
iris
})
shared_iris <- SharedData$new(jittered_iris)
output$scatter1 <- renderD3scatter({
d3scatter(shared_iris, ~Petal.Length, ~Petal.Width, ~Species, width = "100%",
x_lim = range(iris$Petal.Length), y_lim = range(iris$Petal.Width))
})
output$scatter2 <- DT::renderDataTable({
datatable(shared_iris)
}, server = FALSE)
}
shinyApp(ui, server)
DT should throw an error when using Crosstalk with server-side processing
Error in widgetFunc: Crosstalk only works with DT client mode: DT::renderDataTable({...}, server=FALSE)
but I think that broke here: https://github.com/rstudio/DT/commit/893708ca10def9cfe0733598019b62a8230fc52b
Guess I can file an issue on this if no one else has.
I'm working on leaflet with shiny. The tools is basic, i have a map with some markers (coming from a table with LONG and LAT).
What I want to do is to open a table or a graph when i click on the marker.
Is there a simple way to do it?
Do you have a really simple example: you have a maker on a map, you click on the marker, and there is a plot or a table or jpeg that s opening?
Here is another example, taken from here and a little bit adapted. When you click on a marker, the table below will change accordingly.
Apart from that, a good resource is this manual here:
https://rstudio.github.io/leaflet/shiny.html
library(leaflet)
library(shiny)
myData <- data.frame(
lat = c(54.406486, 53.406486),
lng = c(-2.925284, -1.925284),
id = c(1,2)
)
ui <- fluidPage(
leafletOutput("map"),
p(),
tableOutput("myTable")
)
server <- shinyServer(function(input, output) {
data <- reactiveValues(clickedMarker=NULL)
# produce the basic leaflet map with single marker
output$map <- renderLeaflet(
leaflet() %>%
addProviderTiles("CartoDB.Positron") %>%
addCircleMarkers(lat = myData$lat, lng = myData$lng, layerId = myData$id)
)
# observe the marker click info and print to console when it is changed.
observeEvent(input$map_marker_click,{
print("observed map_marker_click")
data$clickedMarker <- input$map_marker_click
print(data$clickedMarker)
output$myTable <- renderTable({
return(
subset(myData,id == data$clickedMarker$id)
)
})
})
})
shinyApp(ui, server)
There is a leaflet example file here:
https://github.com/rstudio/shiny-examples/blob/ca20e6b3a6be9d5e75cfb2fcba12dd02384d49e3/063-superzip-example/server.R
# When map is clicked, show a popup with city info
observe({
leafletProxy("map") %>% clearPopups()
event <- input$map_shape_click
if (is.null(event))
return()
isolate({
showZipcodePopup(event$id, event$lat, event$lng)
})
})
Online demo (see what happens when you click on a bubble):
http://shiny.rstudio.com/gallery/superzip-example.html
On the client side, whenever a click on a marker takes place, JavaScript takes this event and communicates with the Shiny server-side which can handle it as input$map_shape_click.
I have a drop down menu which is a selectizeInput - using which I need to subset my dataframe for analysis further.
Consider the following,
d - dataframe (has a column named 'test')
menu - the selectizeInput drop down
d[d$test %in% input$menu, ]
This doesn't do what I actually need to. Any thoughts?
It should work.
ui
library(shiny)
shinyUI(fluidPage(
sidebarLayout(
sidebarPanel(
selectizeInput("in", "in", choices = as.list(letters[1:10]), multiple = TRUE)
),
mainPanel(
verbatimTextOutput("view")
)
)
))
server
library(shiny)
d <- data.frame(test = letters[1:10], value = 1:10)
shinyServer(function(input, output) {
view <- reactive({d[d$test %in% input$"in", ]})
output$view <- renderPrint(view())
})
How can I get the list of choices in a SelectInpute?
ui.R
selectInput(inputId = "select_gender",
label = "Gender",
choices = c("Male","Female"),
width = 150
)
server.R
# Something like...
genders <- input$select_gender["choices"]
# So that the gender would be:
> genders
[1] Male Female
From the scoping rules of Shiny:
Objects defined in global.R are similar to those defined in app.R outside of the server function definition, with one important difference: they are also visible to the code in the ui object. This is because they are loaded into the global environment of the R session; all R code in a Shiny app is run in the global environment or a child of it.
However, this doesn't mean that objects defined in the app.R can't be used on both the UI and Server side, they just belong to a different environment.
For example:
library("shiny")
library("pryr")
# or in global.R
genders <- c("Male", "Female")
gen_env <- where("genders")
par_env <- parent.env(gen_env)
ui <- fluidPage(
selectInput("shiny_gender", "Select Gender", choices = genders),
verbatimTextOutput("selected_gender_index"),
p("The `genders` object belongs to the environment:"),
verbatimTextOutput("gen_env_print"),
p("Which is the child of the environment:"),
verbatimTextOutput("par_env_print")
)
server <- function(input, output) {
output$selected_gender_index <- renderPrint({
# use the 'genders' vector on the server side as well
which(genders %in% input$shiny_gender)
})
output$gen_env_print <- renderPrint(gen_env)
output$par_env_print <- renderPrint(par_env)
}
shinyApp(ui = ui, server = server)
I've looked for get choices of selectinput but without recompute the choices. For example if the datas come from database, or file or other source.
And I didn't get answer. (I get this question but not the solution for me).
Here is ma solution which also could set the selectinput from the server:
set the choices list in a reactive function
build the selectinput in the server side (with the choices list reactive function)
set and get the selectinput in the server side
Here is the code
options(encoding = "UTF-8")
library("shiny")
library("pryr")
ui <- fluidPage(
uiOutput("shiny_gender.UI"),
verbatimTextOutput("selected_gender_index"),
p("The `genders` object belongs to the environment:"),
verbatimTextOutput("gen_env_print"),
p("Which is the child of the environment:"),
verbatimTextOutput("par_env_print"),
p(""),
textInput("set_input_txt","Set the car in letter (for example `Datsun 710`)",
#" Set the Select Input Male / Female ",
""),
actionButton("submit","submit")
)
server <- function(input, output, session) {
observeEvent(
c(input$submit),
{
if (input$submit>0) {
updateSelectInput(session, "shiny_gender",
# server = TRUE, if updateSelectizeInput
choices =shiny_gender.list(),
selected = input$set_input_txt
)
}
}
)
shiny_gender.list <- reactive ({
#c("Male", "Female")
rownames(mtcars)
})
output$shiny_gender.UI <- renderUI({
selectInput( "shiny_gender",
label="Select car",#"Select Gender",
choices =shiny_gender.list()
)
})
output$selected_gender_index <- renderPrint({
which(shiny_gender.list() %in% input$shiny_gender)
})
output$gen_env_print <- renderPrint(where("shiny_gender.list"))
output$par_env_print <- renderPrint(parent.env( where("shiny_gender.list")))
}
shinyApp(ui = ui, server = server)