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've managed to filter a DataTable with two SelectInput in my code. But, when I try to do the same in my boxplot and histogram it doesn't seem to filter. Is there, by any chance, someone to help me with this? I'm new to shiny.
My code is something like this:
afastamentos <- readr::read_csv("base_afastamentos.csv", locale = locale(encoding = "latin1"))
colnames(afastamentos) <- c(
"Descrição do Cargo", "Nome do Órgão de Origem", "UF", "Cidade da Residência",
"Nível da Escolaridade", "Início do Afastamento", "Ano/Mês Referência",
"Valor do Rendimento Líquido", "Descrição do Afastamento", "Ano Início Afastamento",
"Mês Início Afastamento", "Rendimento Líquido Hora")
ui <- dashboardPage(
dashboardHeader(title = "COBRADI",
titleWidth = 500,
tags$li(class = "dropdown",
tags$a(href = "https://www.ipea.gov.br/portal/index.php?option=com_content&view=article&id=39285&Itemid=343",
icon("globe", lib = "glyphicon"),
"Site COBRADI",
target = "_blank"))
),
dashboardSidebar(
sidebarMenu(
id = "sidebar",
menuItem("Dataset",
tabName = "data",
icon = icon("database")),
menuItem("Visualização",
tabName = "viz",
icon = icon("chart-line")),
menuItem("Informações",
tabName = "info",
icon = icon("info-circle"))
)
),dashboardBody(
tabItems(
tabItem(tabName = "viz",
tabBox(id = "t2", width = 12,
tabPanel(title = "Distribuição Amostral",
icon = icon("fas fa-chart-area"),
value = "trends",
fluidRow(
column(width = 12,
box(title = "Filtros", width = "100%",
column(width = 6,
box(width = "100%",
selectizeInput(inputId = "select_UF",
label = "Estados:",
choices = c("TODOS", unique(afastamentos$UF)),
multiple = T,
selected = "TODOS"))
),
column(width = 6,
box(width = "100%",
selectizeInput(inputId = "descricao_2",
label = "Descrição do Afastamento:",
choices = c("TODOS", unique(afastamentos$`Descrição do Afastamento`)),
multiple = T, options = list(maxItems = 5),
selected = "TODOS"))),
)
)
),
fluidRow(
column(width = 12,
box(title = "BoxPlot - Valor do Rendimento Bruto Mensal",
status = "primary",
solidHeader = TRUE,
collapsible = TRUE,
width = "100%",
plotlyOutput("boxplot"))
),
column(width = 12,
box(title = "Histograma - Valor do Rendimento Bruto Mensal",
status = "primary",
solidHeader = TRUE,
collapsible = TRUE,
width = "100%",
plotlyOutput("histplot")))
)
)
)
)
)
)
)
And the server is:
server <- function(input, output, session){
meus_dados <- reactive({
## filtro UF
print(input)
if (! "TODOS" %in% input$select_UF){
a <- a |>
filter(`UF` %in% input$select_UF)
}
#Filtro Descricao
if(! "TODOS" %in% input$descricao_2){
a <- a |>
filter(`Descrição do Afastamento` %in% input$descricao_2)
return(a)
}
})
output$boxplot <- renderPlotly({
boxplot <- meus_dados()|>
plot_ly() |>
add_boxplot(~`Valor do Rendimento Líquido`) |>
layout(xaxis = list(title = "Valor do Rendimento Bruto"))
})
output$histplot <- renderPlotly({
hist <- meus_dados() |>
plot_ly() |>
add_histogram(~`Rendimento Líquido Hora`) |>
layout(xaxis = list(title = "Valor da Hora Técnica"))})
}
And I get the following error: First argument data must be a data frame or shared data.
Data is available here: https://www.dropbox.com/s/kjilkkskggi27vo/base_afastamentos.csv?dl=0
Your reactive object was the problem. This works fine for me using the original names.
ui <- dashboardPage(
dashboardHeader(title = "COBRADI",
titleWidth = 500,
tags$li(class = "dropdown",
tags$a(href = "https://www.ipea.gov.br/portal/index.php?option=com_content&view=article&id=39285&Itemid=343",
icon("globe", lib = "glyphicon"),
"Site COBRADI",
target = "_blank"))
),
dashboardSidebar(
sidebarMenu(
id = "sidebar",
menuItem("Dataset",
tabName = "data",
icon = icon("database")),
menuItem("Visualização",
tabName = "viz",
icon = icon("chart-line")),
menuItem("Informações",
tabName = "info",
icon = icon("info-circle"))
)
),dashboardBody(
tabItems(
tabItem(tabName = "viz",
tabBox(id = "t2", width = 12,
tabPanel(title = "Distribuição Amostral",
icon = icon("fas fa-chart-area"),
value = "trends",
fluidRow(
column(width = 12,
box(title = "Filtros", width = "100%",
column(width = 6,
box(width = "100%",
selectizeInput(inputId = "select_UF",
label = "Estados:",
choices = c("TODOS", unique(afastamentos$UF_da_UPAG_de_vinculacao)),
multiple = T,
selected = "TODOS"))
),
column(width = 6,
box(width = "100%",
selectizeInput(inputId = "descricao_2",
label = "Descrição do Afastamento:",
choices = c("TODOS", unique(afastamentos$Descricao_do_afastamento)),
multiple = T, options = list(maxItems = 5),
selected = "TODOS"))),
)
)
),
fluidRow(
column(width = 12,
box(title = "BoxPlot - Valor do Rendimento Bruto Mensal",
status = "primary",
solidHeader = TRUE,
collapsible = TRUE,
width = "100%",
plotlyOutput("boxplot"))
),
column(width = 12,
box(title = "Histograma - Valor do Rendimento Bruto Mensal",
status = "primary",
solidHeader = TRUE,
collapsible = TRUE,
width = "100%",
plotlyOutput("histplot")))
)
)
)
)
)
)
)
server <- function(input, output, session){
meus_dados <- reactive({
## filtro UF
print(input)
a <- afastamentos
if (! "TODOS" %in% input$select_UF){
a <- a |>
filter(UF_da_UPAG_de_vinculacao %in% input$select_UF)
}
#Filtro Descricao
if(! "TODOS" %in% input$descricao_2){
a <- a |>
filter(Descricao_do_afastamento %in% input$descricao_2)
}
return(a)
})
output$boxplot <- renderPlotly({
boxplot <- meus_dados()|>
plot_ly() |>
add_boxplot(~Valor_rendimento_liquido) |>
layout(xaxis = list(title = "Valor do Rendimento Bruto"))
})
output$histplot <- renderPlotly({
hist <- meus_dados() |>
plot_ly() |>
add_histogram(~Rendimento_Liquido_Hora) |>
layout(xaxis = list(title = "Valor da Hora Técnica"))})
}
shinyApp(ui = ui, server = server)
output$plot <- renderImage({
outfile <- tempfile(fileext = '.png')
png(outfile, width = 400, height = 300)
venn.diagram(
x = list(
T = T,
I = I
),
main = "Venn Diagram ",
filename =outfile, output=TRUE,
lwd = 2,na = "remove",
fill = c("orange", "blue"),
alpha = c(0.5,0.5),
label.col = "black",
cex=1.5,
fontface = "plain",
cat.col = c("cornflowerblue", "pink"),
cat.cex = 1.5,
cat.fontfamily = "serif",
cat.fontface = "plain",
cat.dist = c(0.05, 0.05),
cat.pos = c(-20, 14),
cat.default.pos = "text",
scaled = FALSE
)
dev.off()
list(src = outfile,
contentType = 'image/png',
width = 400,
height = 300,
alt = "This is alternate text")
}, deleteFile = TRUE)
I was trying plot a venn diagram using this code. But it only displays This is alternate text and not outputting any image on the app, Any Idea ?
Try to create a reactive graph as shown below
output$plot <- renderImage({
vennd <- reactive({venn.diagram(
x = list(
T = T,
I = I
),
main = "Venn Diagram ",
filename =outfile, output=TRUE,
lwd = 2,na = "remove",
fill = c("orange", "blue"),
alpha = c(0.5,0.5),
label.col = "black",
cex=1.5,
fontface = "plain",
cat.col = c("cornflowerblue", "pink"),
cat.cex = 1.5,
cat.fontfamily = "serif",
cat.fontface = "plain",
cat.dist = c(0.05, 0.05),
cat.pos = c(-20, 14),
cat.default.pos = "text",
scaled = FALSE
)
})
outfile <- tempfile(fileext = '.png')
png(outfile, width = 400, height = 300)
vennd()
dev.off()
list(src = outfile,
contentType = 'image/png',
width = 400,
height = 300,
alt = "This is alternate text")
}, deleteFile = TRUE)
output$plot <- renderImage({
vennd <- reactive({venn.diagram(
x = list(
T = T,
I = I
),
main = "",
filename =outfile, output=TRUE,
lwd = 2,na = "remove",imagetype="png",
fill = c("orange", "blue"),
alpha = c(0.5,0.5),
label.col = "black",
cex=1.5,
fontface = "plain",
cat.col = c("cornflowerblue", "pink"),
cat.cex = 1.5,
cat.fontfamily = "serif",
cat.fontface = "plain",
cat.dist = c(0.05, 0.05),
cat.pos = c(-20, 14),
cat.default.pos = "text",
scaled = FALSE
)
})
outfile <- tempfile(fileext = '.png')
png(outfile, width = 500, height = 500,type="cairo")
vennd()
dev.off()
list(src = outfile,
contentType = 'image/png',
width = 500,
height = 500,
alt = "This is alternate text")
}, deleteFile = TRUE)
Need to add imagetype="png" and type="cairo" thank you #YBS
I would like to have my input panel as a sidebar on the left instead if below. I tried the sidebarLayout but did get it to work. Any suggestions?
Input
dput(df1.t)
structure(list(`hsa-let-7a-3p` = c(5.58182112427671, 5.21705272399953,
5.42864356356758, -1.1383057411356, 5.06203248358181), `hsa-let-7a-5p` = c(17.0260439263402,
15.2857710138151, 17.1420214989373, 15.1034766165351, 14.5449390552056
), `hsa-let-7b-3p` = c(4.28580929310353, 2.46805733598209, 5.15298557165018,
4.63298501632773, -0.398732335974934), `hsa-let-7b-5p` = c(13.0477955183433,
10.880357260433, 12.2652935281359, 11.1312184397251, 7.45844929748327
), `hsa-let-7c-3p` = c(-1.25421892418566, -1.27175388669896,
-1.33049811927568, -1.1383057411356, 2.24661989371122)), class = "data.frame", row.names = c("86",
"175", "217", "394", "444"))
dput(df2.t)
structure(list(A1BG = c(-1.19916952580483, -3.10305950914023,
-3.10305950914023, -3.10305950914023, -0.982321345582416), `A1BG-AS1` = c(0.102743641800478,
-2.24464338564074, -3.10305950914023, -1.92943473454654, -0.652692243977369
), A1CF = c(-3.10305950914023, -2.24464338564074, -2.18375470186949,
-1.92943473454654, -2.30044547836697), A2M = c(3.42115035042484,
-0.0469232989985426, 6.84141032645296, 5.78124672930663, 2.53353451576527
), `A2M-AS1` = c(-2.03481283871687, -3.10305950914023, -2.18375470186949,
-3.10305950914023, -2.64664301822906)), class = "data.frame", row.names = c("86",
"175", "217", "394", "444"))
Script
ui <- fluidPage(
titlePanel("MicroRNA-mRNA correlation plot"),
mainPanel(
plotOutput("plot")
),
selectInput(inputId ="data1",
label = "Choose Gene",
choices = names(df2.t),
selected = NULL
),
selectInput(inputId ="data2",
label = "Choose MicroRNA",
choices = names(df1.t),
selected = NULL
),
textOutput("result"))
server <- function(input,output){
data <- eventReactive(c(input$data1,input$data2),{
data <- data.frame(df1.t[[input$data2]], df2.t[[input$data1]])
colnames(data) <- c("col1", "col2")
data
})
output$plot <- renderPlot({
ggplot(data(),aes(x=col2,y=col1)) +
geom_point(colour='black') +
labs(x = paste(input$data1,"(cpm, log2)"), y = paste(input$data2,"(cpm, log2)")) +
theme_classic(base_size = 12) +
geom_smooth(method="lm",se = F) +
stat_cor()
}, height = 400, width = 600)
}
shinyApp(ui=ui,server=server)
Try this:
ui <- fluidPage(
titlePanel("MicroRNA-mRNA correlation plot"),
sidebarLayout(
sidebarPanel(
selectInput(inputId ="data1",
label = "Choose Gene",
choices = names(df2.t),
selected = NULL
),
selectInput(inputId ="data2",
label = "Choose MicroRNA",
choices = names(df1.t),
selected = NULL
)
),
mainPanel(
plotOutput("plot"),
textOutput("result")
)
)
)
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;",
"}")