Related
I am trying to reproduce the decomposed time series plot with highchart.
The result is perfect in the working directory of r but when I put it in r shiny no result comes out.
Here is my code
library(shinyjs)
library(shiny)
library(shinydashboard)
library(highcharter)
library(forecast)
shinyOptions(bslib = TRUE)
bs_global_theme()
bs_theme_base_colors(bg = "#002B36", fg = "#EEE8D5")
bs_theme_accent_colors(primary = "#2AA198")
thematic::thematic_shiny()
ui<-fluidPage(
theme=shinytheme("cerulean"),
themeSelector(),
useShinyjs(),
navbarPage(
title= "Stock exchange", position = "static-top",
id="nav",
tabPanel("Single stock analysis",value = "single_stock", icon = icon("chart-area"),
sidebarLayout(
div(id = "Sidebar",
sidebarPanel(width = 3, align = "center",
selectInput("ticker",
strong("Ticker"),
# quotes$Symbole,
choices = c("AirPassengers", "ttrc"),
selectize = TRUE
),
dateRangeInput("date", strong("Select data range"),
start = "2012-01-01", end = (Sys.Date()-1)
),
tags$br(),
fluidPage(column(width = 3, "Session")
)
)),
mainPanel(
fluidRow(align = "center",
selectInput("hideorshow", label = strong("Sidebar disposition"),
choices = c("Show", "Hide"), selected = "Show")),
tabsetPanel(
tabPanel("Data structure and summary",
icon = icon("table"),
h1(align = "center",
strong(" STRUCTURE OF THE DATAFRAME ")),
tags$br(),tags$b(),class="fa fa-table",
verbatimTextOutput("struc"),
tags$br(),tags$br(),
h1(align = "center",strong(" SUMMARY OF THE DATAFRAME ")),
br(),verbatimTextOutput("summary1")
),
tabPanel("Dataset",icon = icon("tablet-alt"), DTOutput('tbl1')),
tabPanel("Plot",icon = shiny::icon('chart-bar'), br(),br(), br(),
airDatepickerInput(inputId = "date.ts",
strong("Time of the first observation"),
value = "2017-01-01",
minDate = "1998-09-16",
maxDate = Sys.Date(),
view = "months",
minView = "months",
dateFormat = "yyyy-mm"),
highchartOutput("closing_pr.ts",width = "auto", height = "600px"),
),
)
)
)),
tabPanel("Multiple stocks analysis", tabName = "mult_stock", icon = icon("th"))
)
)
I think the problem is hide in the server; exactely the renderHighchart but i can't find it. Please any help will be appreciate.
cs <- new.env()
dt_new <- eventReactive(c(input$ticker,input$date[1],input$date[2]), {
if (input$ticker =="AirPassengers"){
data(AirPassengers)
mydata1 <- AirPassengers
}
else if (input$ticker =="ttrc"){
data(ttrc)
mydata1 <- ttrc
}
mydata1
})
output$closing_pr.ts<-renderHighchart({
year.ts <- as.numeric(year(input$date.ts))
month.ts <- as.numeric(month(input$date.ts))
dc <- decompose(AirPassengers)
df <- as.data.frame(dc[c("x","trend","seasonal","random")])
df2 <- data.frame(Date = index(dc$x),
apply(df, 2, as.numeric))
names(df2) <- c("Date", "Observed", "Trend", "Seasonal", "Random")
df2$Date <- as.Date(yearmon(df2$Date))
df2 <- as.xts(df2[,-c(1)],
order.by = df2$Date)
df2 <- round(df2, digits = 3)
highchart(type = "stock") %>%
hc_title(text = "TIME SERIE DECOMPOSITION") %>%
hc_add_series(df2[, "Observed"], yAxis = 0, name = "Observed", showInLegend = FALSE) %>%
hc_add_yAxis(nid = 1L, title = list(text = "Observed"), relative = 2) %>%
hc_add_series(df2[, "Trend"], yAxis = 1, type = "line",name = "Trend", showInLegend = FALSE) %>%
hc_add_yAxis(nid = 2L, title = list(text = "Trend"), relative = 1)%>%
hc_add_series(df2[, "Seasonal"], yAxis = 2, type = "line",name = "Seasonal", showInLegend = FALSE) %>%
hc_add_yAxis(nid = 1L, title = list(text = "Seasonal"), relative = 2) %>%
hc_add_series(df2[, "Random"], yAxis = 3, type = "line", name = "Random", showInLegend = FALSE) %>%
hc_add_yAxis(nid = 2L, title = list(text = "Random"), relative = 1)%>%
hc_exporting(
enabled = TRUE, # always enabled,
filename = paste0("Closing price decomposition line charts from ",
min(index(df2)),
" to ", max(index(df2))))%>%
hc_colors(colors = c("blue", "red", "cyan", "darkgreen"))
})
observeEvent(input$hideorshow, {
if ( input$hideorshow== "Show") {
shinyjs::show(id = "Sidebar")}
else {shinyjs::hide(id = "Sidebar")}
})
output$summary1 <- renderPrint({
summary(dt_new())
})
output$struc<- renderPrint({
str(dt_new())
})
}
shinyApp(ui=ui, server = server)
Try this
library(shinyjs)
library(shiny)
library(shinydashboard)
library(highcharter)
library(forecast)
library(lubridate)
library(zoo)
library(xts)
shinyOptions(bslib = TRUE)
# bs_global_theme()
# bs_theme_base_colors(bg = "#002B36", fg = "#EEE8D5")
# bs_theme_accent_colors(primary = "#2AA198")
# thematic::thematic_shiny()
ui<-fluidPage(
#theme=shinytheme("cerulean"),
#themeSelector(),
useShinyjs(),
navbarPage(
title= "Stock exchange", position = "static-top",
id="nav",
tabPanel("Single stock analysis",value = "single_stock", icon = icon("chart-area"),
sidebarLayout(
div(id = "Sidebar",
sidebarPanel(width = 3, align = "center",
selectInput("ticker",
strong("Ticker"),
# quotes$Symbole,
choices = c("AirPassengers", "ttrc"),
selectize = TRUE
),
dateRangeInput("date", strong("Select data range"),
start = "2012-01-01", end = (Sys.Date()-1)
),
tags$br(),
fluidPage(column(width = 3, "Session")
)
)),
mainPanel(
fluidRow(align = "center",
selectInput("hideorshow", label = strong("Sidebar disposition"),
choices = c("Show", "Hide"), selected = "Show")),
tabsetPanel(
tabPanel("Data structure and summary",
icon = icon("table"),
h1(align = "center",
strong(" STRUCTURE OF THE DATAFRAME ")),
tags$br(),tags$b(),class="fa fa-table",
verbatimTextOutput("struc"),
tags$br(),tags$br(),
h1(align = "center",strong(" SUMMARY OF THE DATAFRAME ")),
br(),verbatimTextOutput("summary1")
),
tabPanel("Dataset",icon = icon("tablet-alt"), DTOutput('tbl1')),
tabPanel("Plot",icon = shiny::icon('chart-bar'), br(),br(), br(),
airDatepickerInput(inputId = "date.ts",
strong("Time of the first observation"),
value = "2017-01-01",
minDate = "1998-09-16",
maxDate = Sys.Date(),
view = "months",
minView = "months",
dateFormat = "yyyy-mm"),
highchartOutput("closing_prts",width = "auto", height = "600px"),
),
)
)
)),
tabPanel("Multiple stocks analysis", tabName = "mult_stock", icon = icon("th"))
)
)
server <- function(input, output, session){
cs <- new.env()
# dt_new <- eventReactive(c(input$ticker,input$date[1],input$date[2]), {
dt_new <- reactive({
if (input$ticker =="AirPassengers"){
data(AirPassengers)
print("Hello")
mydata1 <- AirPassengers
} else if (input$ticker =="ttrc"){
data(ttrc)
mydata1 <- ttrc
}
as.data.frame(mydata1)
})
df1 <- reactive({
year.ts <- as.numeric(year(input$date.ts))
month.ts <- as.numeric(month(input$date.ts))
dc <- decompose(AirPassengers)
df <- as.data.frame(dc[c("x","trend","seasonal","random")])
df2 <- data.frame(Date = index(dc$x),
apply(df, 2, as.numeric))
names(df2) <- c("Date", "Observed", "Trend", "Seasonal", "Random")
df2$Date <- as.Date(yearmon(df2$Date))
df2 <- as.xts(df2[,-c(1)],
order.by = df2$Date)
df2 <- round(df2, digits = 3)
df2
})
output$closing_prts <- renderHighchart({
df2 <- df1()
highchart(type = "stock") %>%
hc_title(text = "TIME SERIE DECOMPOSITION") %>%
hc_add_series(df2[, "Observed"], yAxis = 0, name = "Observed", showInLegend = FALSE) %>%
hc_add_yAxis(nid = 1L, title = list(text = "Observed"), relative = 2) %>%
hc_add_series(df2[, "Trend"], yAxis = 1, type = "line",name = "Trend", showInLegend = FALSE) %>%
hc_add_yAxis(nid = 2L, title = list(text = "Trend"), relative = 1)%>%
hc_add_series(df2[, "Seasonal"], yAxis = 2, type = "line",name = "Seasonal", showInLegend = FALSE) %>%
hc_add_yAxis(nid = 1L, title = list(text = "Seasonal"), relative = 2) %>%
hc_add_series(df2[, "Random"], yAxis = 3, type = "line", name = "Random", showInLegend = FALSE) %>%
hc_add_yAxis(nid = 2L, title = list(text = "Random"), relative = 1)%>%
hc_exporting(
enabled = TRUE, # always enabled,
filename = paste0("Closing price decomposition line charts from ",
min(index(df2)),
" to ", max(index(df2))))%>%
hc_colors(colors = c("blue", "red", "cyan", "darkgreen"))
})
observeEvent(input$hideorshow, {
if ( input$hideorshow== "Show") {
shinyjs::show(id = "Sidebar")}
else {shinyjs::hide(id = "Sidebar")}
})
output$tbl1 <- renderDT({datatable(dt_new())})
output$summary1 <- renderPrint({
summary(dt_new())
})
output$struc<- renderPrint({
str(dt_new())
})
}
shinyApp(ui, server)
I am wroking on an shiny app as a volonteer trying to produce an app that would register all of the calls citizens have in the these times of a lockdown for a local Red Cross office. I have managed to get the entry form and to review the DT, but I need to the DT editable so I have included some code to do that.
All is working, except when I write the changes in some of the columns the app changes the column -1 (one to left), overwrites its previous entry in column -1 that I didn't wanted to edit and leaves the entry I actually wanted to edit in the column I wanted to edit (if that makes any sense). What am I doing wrong? I am pasting the code, datasets stored on Dropbox.
## app.R ##
# load the required packages
library(shiny)
library(shinyjs)
require(shinydashboard)
library(ggplot2)
library(dplyr)
library(DT)
library(data.table)
# Obavezna polja
fieldsMandatory <- c("Ime", "Prezime", "Problem")
# Označiti obavezna polja s crvenim asteriksom
labelMandatory <- function(label) {
tagList(
label,
span("*", class = "mandatory_star")
)
}
# CSS za obavezna polja, *
appCSS <-
".mandatory_star { color: red; }"
# HumanTime za time stamp u csv
humanTime <- function() format(Sys.time(), "%Y%m%d-%H%M%OS")
# Čuvanje odgovora u folderu "reponses"
fieldsAll <- c("Ime", "Prezime", "Adresa", "BrojTel", "OIB",
"Problem", "Pomagac","Trajanje","Rjesenje")
# DropBox autorizacija
library(rdrop2)
# This will launch your browser and request access to your Dropbox account.
# You will be prompted to log in if you aren't already logged in.
#drop_auth()
# Once completed, close your browser window and return to R to complete authentication.
# The credentials are automatically cached (you can prevent this) for future use.
# If you wish to save the tokens, for local/remote use
#token <- drop_auth()
#saveRDS(token, file = "dropbox_token.rds")
# Then in any drop_* function, pass `dtoken = token
# Tokens are valid until revoked.
outputDir <- "responses"
outputJedan <- "reponsesJedanFajl"
loadData <- function() {
files_info <- drop_dir(outputDir)
file_paths <- files_info$path_display
# Only take the last 20 because each file takes ~1 second to download
file_paths <- tail(file_paths, 1)
zadnji <-
lapply(file_paths, drop_read_csv, stringsAsFactors = FALSE, encoding = 'UTF-8') %>%
do.call(rbind, .)
write.csv(zadnji, "zadnji.csv", row.names = FALSE, quote = TRUE, fileEncoding = "UTF-8")
# Upload the file to Dropbox
drop_upload("zadnji.csv", path = outputDir, mode = "overwrite")
# files_info2 <- drop_dir(outputJedan)
# file_paths2 <- files_info2$path_display
# Only take the last 20 because each file takes ~1 second to download
#file_paths2 <- tail(file_paths, 20)
data <-
lapply(c("responses/zadnji.csv", "reponsesJedanFajl/fajl.csv"),
drop_read_csv, stringsAsFactors = FALSE, encoding = 'UTF-8') %>%
do.call(rbind, .)
write.csv(data, "fajl.csv", row.names = FALSE, quote = TRUE, fileEncoding = "UTF-8")
# Upload the file to Dropbox
drop_upload("fajl.csv", path = outputJedan, mode = "overwrite")
data
}
# UI
ui <- dashboardPage(
dashboardHeader(title = "HDCK-ČK Dashboard"),
skin = "red",
## Sidebar content
dashboardSidebar(
collapsed = TRUE,
sidebarMenu(
#menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")),
menuItem("Evidencija", tabName = "evidencija", icon = icon("th")),
#menuItem("Evidencija", tabName = "evidencija", icon = icon("th")),
menuItem("Sajt", icon = icon("send",lib='glyphicon'),
href = "http://www.crveni-kriz-cakovec.hr")
)
),
## Body content
dashboardBody(
tabItems(
# First tab content
tabItem(
tabName = "evidencija",
navbarPage("",
tabPanel("Upis",
fluidPage(
shinyjs::useShinyjs(),
shinyjs::inlineCSS(appCSS),
sidebarPanel(
width = 3,
id = "form",
textInput("Ime", labelMandatory("1. Ime")),
textInput("Prezime", labelMandatory("2. Prezime")),
textInput("Adresa", label = "3. Adresa (ulica i broj, mjesto)"),
textInput(inputId = "BrojTel", label = "4. Broj telefona",
value = NULL),
numericInput(inputId = "OIB", label = "5. OIB", value = NULL),
#checkboxInput("CZSS", "Označiti ako je korisnik CZSS", FALSE),
#sliderInput("Dob", "5. Dob", 1, 100, 50, ticks = FALSE),
textAreaInput("Problem", labelMandatory("6. Opis problema ili potrebe"),
"", height = 100),
textAreaInput("Rjesenje", "7. Na koji način je problem riješen?",
"", height = 50),
selectInput("Pomagac", "8. Pomagač",
c("", "Barbara", "Elizabeta",
"Ines", "Iva", "Lana", "Vlatka", "Željka")),
numericInput(inputId = "Trajanje", label = "9. Trajanje razgovora u min", value = 5),
actionButton("submit", "Unesi")#, class = "btn-primary")
),
mainPanel(
width = 9,
h3("Tablica s pregledom prethodnih zapisa:"),
DT::dataTableOutput("responsesTable"),
style = "overflow-y: scroll;overflow-x: scroll; overflow: auto;",
#downloadButton("downloadBtn", "Skini *.csv"),
# br(),
# actionButton("viewBtn","View"),
br(),
actionButton("saveBtn", "Zapiši rješenje", style="float:right")
# br(),
# DT::dataTableOutput("updated.df")
)
)),
tabPanel("Upute"
)
)
)
)
)
)
# Server
# Učitavnje podataka na prvom učitavnju app
tablica <- function() {
data <- drop_read_csv("reponsesJedanFajl/fajl.csv", fileEncoding = "UTF-8",
stringsAsFactors = FALSE)
data
}
server <- function(input, output, session) {
drop_auth(rdstoken = "dropbox_token.rds")
# Prikaži tablicu na onload
tablicica <- data.frame(tablica())
output$responsesTable <- DT::renderDataTable(
tablicica,
selection = "none",
editable = TRUE,
rownames = FALSE,
extensions = 'Buttons',
server = FALSE,
options = list(
paging = TRUE,
searching = TRUE,
scroller = TRUE,
dom = 'Bfrtip',
extensions = c('Responsive', 'Buttons'),
buttons = c('excel', 'pdf', 'copy', 'csv', 'print')
))
# Provjera obaveznih polja kod upisa
observe({
mandatoryFilled <-
vapply(fieldsMandatory,
function(x) {
!is.null(input[[x]]) && input[[x]] != ""
},
logical(1))
mandatoryFilled <- all(mandatoryFilled)
shinyjs::toggleState(id = "submit", condition = mandatoryFilled)
})
# Čuvanje pojedinih inputa u csv nakon upisa
formData <- reactive({
data <- sapply(fieldsAll, function(x) input[[x]])
data <- c(data, VremenskiPoredak = humanTime())
data <- t(data)
data
})
# Čuvanje inputa u pojedinim csv i što učiniti nakon što se stisne gumb
saveData <- function(data) {
#data <- t(data)
# Unique file name
fileName <- sprintf("%s_%s.csv", humanTime(), digest::digest(data))
# Čuvanje fajla u prvremenom direktoriju
filePath <- file.path(tempdir(), fileName)
write.csv(data, filePath, row.names = FALSE, quote = TRUE, fileEncoding = "UTF-8")
# Upload fajla na Dropbox
drop_upload(filePath, path = outputDir)
}
# akcija kad se pritisne gumb Zapiši, za zapisivanje novih upisa
observeEvent(input$submit, {
saveData(formData())
# I prikaži tablicu s novim upisima
output$responsesTable <- DT::renderDataTable(
datatable(
loadData(),
rownames = FALSE,
extensions = 'Buttons',
#server = FALSE,
options = list(
paging = TRUE,
searching = TRUE,
#fixedColumns = FALSE,
#autoWidth = TRUE,
#ordering = TRUE,
deferRender = TRUE,
#scrollY = 400,
scroller = TRUE,
dom = 'Bfrtip',
orientation ='landscape',
extensions = c('Responsive', 'Buttons'),
buttons = c('excel', 'pdf', 'copy', 'csv', 'print')
))
)
})
observeEvent(input$responsesTable_cell_edit, {
tablicica[input$responsesTable_cell_edit$row,
input$responsesTable_cell_edit$col] <<- input$responsesTable_cell_edit$value
})
observeEvent(input$saveBtn,{
write.csv(tablicica, "fajl.csv", row.names = FALSE, quote = TRUE, fileEncoding = "UTF-8")
# Upload the file to Dropbox
drop_upload("fajl.csv", path = outputJedan, mode = "overwrite")
# Prikaži tablicu nakon što su unesene promjene
output$responsesTable <- DT::renderDataTable(
datatable(
tablicica,
rownames = FALSE,
options = list(
searching = TRUE,
lengthChange = TRUE
# # fixedColumns = FALSE,
# # autoWidth = TRUE,
# # ordering = FALSE,
# dom = 'tB',
# buttons = c('copy', 'csv', 'excel', 'pdf')
# ),
# # class = "display", #if you want to modify via .css
# # extensions = "Buttons"
))
)
})
# # Download button
# output$downloadBtn <- downloadHandler(
# filename = function() {
# sprintf("evidencija-psihosocijalne_%s.csv", humanTime())
# },
# content = function(file) {
# write.csv(loadData(), file, row.names = FALSE)
# }
# )
# Reset formu nakon submita
observeEvent(input$submit, {
reset("form")
})
}
shinyApp(ui, server)
R and DT count columns differently. In R the leftmost column is column 1. In DT the leftmost column is column 0. This is also known as one or zero-based array indexing.
Adding a few strategic +1 or -1 will do the trick.
If you need help knowing where to put those, feel free to post a minimal example and we can help you work through it.
I am currently trying to add nice user input from shinyWidgets into a DT datatable.
I tried to follow the example from DT github with the radioButtons, which is working fine :
library(DT)
library(shinyWidgets)
m = data.frame(matrix(
as.character(1:5), nrow = 12, ncol = 5, byrow = TRUE,
dimnames = list(month.abb, LETTERS[1:5])
), stringsAsFactors = F)
for (i in seq_len(nrow(m))) {
m[i, ] = sprintf(
'<input type="radio" name="%s" value="%s"/>',
month.abb[i], m[i, ]
)
}
datatable(m, escape = FALSE, options = list(dom = 't', paging = FALSE, ordering = FALSE))
I would like now to have a sixth column with a likert scale, just like presented here : http://shinyapps.dreamrs.fr/shinyWidgets/
The div information is given when the command is executed in the R console. So I tried to add it just like the radioButtons :
library(DT)
library(shinyWidgets)
m = data.frame(matrix(
as.character(1:5), nrow = 12, ncol = 5, byrow = TRUE,
dimnames = list(month.abb, LETTERS[1:5])
), stringsAsFactors = F)
for (i in seq_len(nrow(m))) {
m[i, ] = sprintf(
'<input type="radio" name="%s" value="%s"/>',
month.abb[i], m[i, ]
)
}
m$new_input <- NA
for (i in seq_len(nrow(m))) {
m[i, 6] = sprintf(
'<div class="form-group shiny-input-container">
<label class="control-label" for="Id102">Your choice:</label>
<input class="js-range-slider sw-slider-text" data-data-type="text" data-force-edges="true" data-from="0" data-from-fixed="false" data-from-shadow="false" data-grid="true" data-hide-min-max="false" data-keyboard="true" data-prettify-enabled="false" data-swvalues="["Strongly disagree","Disagree","Neither agree nor disagree","Agree","Strongly agree"]" data-to-fixed="false" data-to-shadow="false" id="%s"/>
</div>',
paste("slider",month.abb[i], sep = "_")
)
}
datatable(m, escape = FALSE, options = list(dom = 't', paging = FALSE, ordering = FALSE))
Unfortunately, this is clearly not giving the input from shinyWidgets.
Any idea ?
Here is an example.
library(shiny)
library(shinyWidgets)
library(DT)
ui <- fluidPage(
br(),
DTOutput("dt"),
br(),
tags$label("Slider1:"),
verbatimTextOutput("choice1"),
tags$label("Slider2:"),
verbatimTextOutput("choice2")
)
sti <- function(id){
as.character(sliderTextInput(
inputId = id,
label = "Your choice:",
grid = TRUE,
force_edges = TRUE,
choices = c("Disagree", "Agree"))
)
}
js <- c(
"function(settings){",
" $('[id^=slider]').each(function(){",
" $(this).ionRangeSlider({values: $(this).data('swvalues')});",
" });",
"}"
)
server <- function(input, output){
dat <- data.frame(
word = c("hello", "goodbye"),
status = c(sti("slider1"), sti("slider2"))
)
output[["dt"]] <- renderDT({
dtable <- datatable(dat, escape = FALSE,
callback = JS(c('Shiny.unbindAll(table.table().node());',
'Shiny.bindAll(table.table().node());')),
options = list(
initComplete = JS(js)
))
dep1 <- htmltools::htmlDependency(
"ionrangeslider", "2.1.6",
src = "www/shared/ionrangeslider",
script = "js/ion.rangeSlider.min.js",
stylesheet = c("css/ion.rangeSlider.css", "css/ion.rangeSlider.skinShiny.css"),
package = "shiny")
dep2 <- htmltools::htmlDependency(
"strftime", "0.9.2",
src = "www/shared/strftime",
script = "strftime-min.js",
package = "shiny")
dep3 <- htmltools::htmlDependency(
"shinyWidgets", "0.4.5",
src = "www",
script = "shinyWidgets-bindings.min.js",
stylesheet = "shinyWidgets.css",
package = "shinyWidgets")
dtable$dependencies <- c(dtable$dependencies, list(dep1,dep2,dep3))
dtable
}, server = FALSE)
output[["choice1"]] <- renderPrint(input[["slider1"]])
output[["choice2"]] <- renderPrint(input[["slider2"]])
}
shinyApp(ui, server)
I have created multiple selectInputs that will alter multiple graphs when something from the drop down menu has been selected. Currently only 3 out of the 5 graphs are working even though they all have the same code. So far the trafficking type, sub type and gender work but the control method and transportation method are not.
UI:
ui <- dashboardPage(
dashboardHeader(title = "Human Trafficking"),
dashboardSidebar(
sidebarMenu(
selectInput("Source", "Choose a Data Source: ", choices = sort(unique(newNgo$Data.Source)), selected = NULL,
multiple = TRUE, selectize = TRUE, width = NULL, size = NULL),
selectInput("Nationality", "Select a nation: ", choices = " "),
dateInput("startdate", "Start Date:", value = "2019-08-01", format = "dd-mm-yyyy",
min = "2000-01-01", max = "2019-09-04"),
dateInput("enddate", "End Date:", value = "2019-09-05", format = "dd-mm-yyyy",
min = "2000-01-02", max = "2019-09-05")
#actionButton("button1", "Apply"),
#actionButton("reset_input", "Reset inputs")
)
),
fluidRow(
box(width = 6, solidHeader = TRUE, status = "primary",
title = "Trafficking Type",
selectInput("traffickingType", "Choose a trafficking type: ",
choices = sort(unique(newNgo$Trafficking.Type)), selected = NULL,
multiple = TRUE, selectize = TRUE, width = NULL, size = NULL),
#actionButton("button2", "Apply"),
plotlyOutput("coolplot", width = '750px', height = '300px')
),
box(width = 6, solidHeader = TRUE, status = "primary",
title = "Trafficking Sub-Type",
selectInput("traffickingSubType", "Choose a trafficking sub type: ",
choices = sort(unique(newNgo$Trafficking.Sub.Type)), selected = NULL,
multiple = TRUE, selectize = TRUE, width = NULL, size = NULL),
#actionButton("button3", "Apply"),
plotlyOutput("Sub", width = '750px', height = '300px')
)
),
fluidRow(
box(width = 4, solidHeader = TRUE, status = "primary",
title = "Victim Gender",
selectInput("victimGender", "Choose a gender: ",
choices = sort(unique(newNgo$Victim.Gender)), selected = NULL,
multiple = TRUE, selectize = TRUE, width = NULL, size = NULL),
#actionButton("button4", "Apply"),
plotlyOutput("gender", width = '250px', height = '200px')
),
box(width = 4, solidHeader = TRUE, status = "primary",
title = "Transport Method",
selectInput("transp", "Choose a transportation method: ",
choices = sort(unique(newNgo$Transportation.Method)), selected = NULL,
multiple = TRUE, selectize = TRUE, width = NULL, size = NULL),
#actionButton("button4", "Apply"),
plotlyOutput("transportMethod", width = '250px', height = '200px')
),
box(width = 4, solidHeader = TRUE, status = "primary",
title = "Control Method",
selectInput("control", "Choose a control method: ",
choices = sort(unique(newNgo$Control.Method)), selected = NULL,
multiple = TRUE, selectize = TRUE, width = NULL, size = NULL),
#actionButton("button4", "Apply"),
plotlyOutput("controlMethod", width = '250px', height = '200px')
)
Server:
output$coolplot <- renderPlotly({
req(input$Nationality)
if(!is.null(input$Nationality)) {
newNgo <- newNgo %>% filter(Victim.Nationality %in% input$Nationality)
}
if(!is.null(input$gender)) {
newNgo <- newNgo %>% filter(Victim.Gender %in% input$gender)
}
if(!is.null(input$traffickingType)) {
newNgo <- newNgo %>% filter(Trafficking.Type %in% input$traffickingType)
}
if(!is.null(input$traffickingSubType)) {
newNgo <- newNgo %>% filter(Trafficking.Sub.Type %in% input$traffickingSubType)
}
if(!is.null(input$Source)) {
newNgo <- newNgo %>% filter(Data.Source %in% input$Source)
}
plot_ly(newNgo, labels = ~Trafficking.Type, type = "pie") %>%
layout(showlegend = FALSE)
})
output$control <- renderPlotly({
req(input$Nationality)
if(!is.null(input$Nationality)) {
newNgo <- newNgo %>% filter(Victim.Nationality %in% input$Nationality)
}
if(!is.null(input$gender)) {
newNgo <- newNgo %>% filter(Victim.Gender %in% input$gender)
}
if(!is.null(input$traffickingType)) {
newNgo <- newNgo %>% filter(Trafficking.Type %in% input$traffickingType)
}
if(!is.null(input$traffickingSubType)) {
newNgo <- newNgo %>% filter(Trafficking.Sub.Type %in% input$traffickingSubType)
}
if(!is.null(input$Source)) {
newNgo <- newNgo %>% filter(Data.Source %in% input$Source)
}
plot_ly(newNgo, labels = ~Control.Method, type = "pie") %>%
layout(showlegend = FALSE)
})
I have attached the code from the server with one graph that works and one that doesn't work. I also attached all the different inputs I have from the UI.
Your plotlyOutput in the ui has the id controlMethod, whereas your output id in the server is control. Change the latter to output$controlMethod.
I am trying to convert cells in a DT:datatable into clickable buttons, which action is append a new tab on my shiny app.
I have been using this post R Shiny: Handle Action Buttons in Data Table as reference but in my case the buttons shows up like this:
My app is a bit more complicated but I will try to re-create the part that does not work
This is an shorter version of my data.frame
mut_genes <- structure(list(acc_num = c("BM0042985", "BM0393251", "BM0673028"), disease = c("Sucrase isomaltase deficiency", "Metachromatic leukodystrophy", "Fatal surfactant deficiency"), gene = c("SI", "ARSA", "ABCA3"), chrom = c("3q25.2-q26.2", "22q13.31-qter", "16p13.3"), genename = c("Sucrase-isomaltase", "arylsulfatase A", "ATP binding cassette subfamily A member 3"), gdbid = c("120377", "119007", "3770735"), omimid = c("609845", "607574", "601615"), amino = c("Leu-Pro", "Glu-Lys", "Met-Ile"), deletion = c(NA_character_, NA_character_, NA_character_), insertion = c(NA_character_, NA_character_, NA_character_), codon = c(341L, 331L, 1L), codonAff = c(341L, 331L, 1L), hgvs = c("1022T>C", "991G>A", "3G>C"), hgvsAll = c("1022TtoC | L341P", "991GtoA | E331K", "3GtoC | M1I"), dbsnp = c("rs267607049", NA, NA), chromosome = c("3", "22", "16"), startCoord = c(165060026L, 50626052L, 2326464L), endCoord = c(165060026L, 50626052L, 2326464L), inheritance = c("AR", "AR", "AR"), gnomad_AC = c(NA_integer_, NA_integer_, NA_integer_), gnomad_AF = c(NA_real_, NA_real_, NA_real_), gnomad_AN = c(NA_integer_, NA_integer_, NA_integer_), mutype = c("missense", "missense", "initiation"), pmid = c("10903344", "12809637", "16641205"), pmidAll = c(NA, NA, "24871971"), base = c("M", "M", "M"), clinvarID = c("1413", NA, NA), clinvar_clnsig = c("Pathogenic", NA, NA), gene_id = c("2073", "190", "10")), row.names = c(NA, -3L), class = c("tbl_df", "tbl", "data.frame"))
library(shiny)
library(shinyjs)
library(tidyverse)
library(DT)
sidebar <- dashboardSidebar(
selectInput("search", label = "Search Options:",
choices = c("General", "Gene", "Mutation", "Reference", "Phenotype"), selected = "Gene"),
sidebarMenu(id="siderbarmenu", sidebarMenuOutput("menu"))
)
header <- dashboardHeader()
body <- dashboardBody(
tags$style(type="text/css",
".shiny-output-error { visibility: hidden; }",
".shiny-output-error:before { visibility: hidden; }",
".shiny-output-error:after { visibility: hidden; }"),
#ui
shinyjs::useShinyjs(),
tabItems(
tabItem("search_general", h1("A was done")),
tabItem(
tabName = "search_exact_gene",
tabsetPanel(
id = "tabs",
tabPanel(
title = "Main Dashboard",
value = "gene1",
fluidRow(
column(12,dataTableOutput("tablafilt_paste_genes"))
)
)
)
)
)
)
ui <- dashboardPage(header, sidebar, body)
And Here is the server part
server <- function(input, output, session) {
output$menu <- renderMenu({
my_general = list(
menuItem("Búsqueda general", tabName="search_general"),
conditionalPanel("input.siderbarmenu == 'search_general'",
textInput(inputId = "search_terms", label = "Search terms"),
selectInput("search_fields", label="Search choices", choices=c("All Fields", "Gene symbol",
"Gene description", "Chromosomal location", "HGNC/OMIM/GDB/Entrez ID", "RefSeq transcript",
"Disease/phenotype", "Gene Ontology"), selected = "Gene symbol"),
actionButton("submit", "Submit query")
)
)
my_gene = list(
menuItem("Búsqueda por gene", tabName="search_exact_gene"),
textInput(inputId = "search_exact_symbol", label = "Exact gene symbol only"),
actionButton("submit3", "Submit query")
)
if(input$search=="General"){
menu = my_general
} else if (input$search=="Gene"){
menu = my_gene
}
sidebarMenu(menu)
})
filtrado <- reactive({
dataset <- input$submit3
glist <- isolate(input$search_exact_symbol)
datos <- filter(mut_genes, gene %in% glist)
shinyInput <- function(FUN, len, id, ...) {
inputs <- character(len)
for (i in seq_len(len)) {
inputs[i] <- as.character(FUN(paste0(id, i), ...))
}
inputs
}
datos <- mutate(datos, Mutacion=shinyInput(
FUN = actionButton,
len = nrow(datos),
id = 'button_',
label = "Mutacion",
onclick = 'Shiny.onInputChange(\"select_button\", this.id)')
)
return(datos)
})
output$tablafilt_paste_genes <- DT::renderDataTable({
if(is.null(filtrado()))
return()
datos <- filtrado()
DT::datatable(datos, escape = FALSE,
rownames = FALSE,
style = 'bootstrap',
class = 'compact cell-border stripe hover',
filter = list(position = 'top', clear = FALSE),
extensions = c('Buttons', "FixedHeader", "Scroller"),
options = list(
stateSave = FALSE,
ordering = FALSE,
autoWidth = TRUE,
search = list(regex = TRUE, caseInsensitive = TRUE),
columnDefs = list(
list(
className = 'dt-center',
targets = 1:ncol(datos)-1L,
render = JS("function(data, type, row, meta) {",
"return type === 'display' && typeof data === 'string' && data.length > 10 ?",
"'<span title=\"' + data + '\">' + data.substr(0, 10) + '...</span>' : data;",
"}")
)
),
initComplete = JS(
"function(settings, json) {",
"$(this.api().table().header()).css({'font-size': '12px'});",
"}"),
sDom = '<"top">Brtp<"bottom">i', # remove search general box and keep the top filters
scrollX = TRUE,
deferRender=TRUE,
buttons = list('colvis'),
FixedHeader = TRUE,
pageLength = 25,
lengthMenu = list(c(25, 50, 100, -1), list('25', '50', '100', 'All'))
),
callback = JS('table.page(3).draw(false); "setTimeout(function() { table.draw(true); }, 300);"')) %>%
formatStyle(columns = colnames(.$x$data), `font-size` = "15px")
})
}
runApp(shinyApp(ui, server))
My ideal situation is recreate the acc_num column and make it a buttom clickable, but when I have tried with
shinyInput <- function(FUN, len, id, label,...) {
inputs <- character(len)
for (i in seq_len(len)) {
label <- datos$acc_num[i]
inputs[i] <- as.character(FUN(paste0(id, i), label=label, ...))
}
inputs
}
It happens the same, I still see the <button id => even when I set the datatable option escape to false
That's because of the quotes. Your render function generates <span title="<button id = "xxx" ...... and this causes the issue.
You don't want to apply the span to the buttons, so add the regex test !(/button/).test(data) in the conditions:
render = JS("function(data, type, row, meta) {",
"return type === 'display' && typeof data === 'string' && data.length > 10 && !(/button/).test(data) ? ",
"'<span title=\"' + data + '\">' + data.substr(0, 10) + '...</span>' : data;",
"}")