shiny app excelR can't control table height - shiny

I'm using ExcelR and Shiny. I can't seem to make the table bigger than say, 13 rows.
Here is example code:
shinyApp(
ui = navbarPage("title", selected = "main",
position = "fixed-top",
tags$style(type="text/css", "body {padding-top: 70px;}"),
tabPanel("main", id = "main",
fluidPage(
excelOutput("table", width = "100%", height = "100%")
)
)
),
server = function(input, output, session) {
output$table <-renderExcel(
excelTable(
data = iris,
autoColTypes = FALSE,
pagination = 5,
#autoFill = TRUE,
fullscreen = FALSE,
lazyLoading = TRUE,
search = TRUE
)
)
}
)
pagination seems to have no effect, and if I switch fullscreen on, the rest of the rows are rendered, but I can't see the searchbar, and the padding between the table and the navbar disappears.
I'm running R 3.6.0

I tried using the same attribute you have, and used it in the standard function and it worked, I also removed the pagination setting
so this worked for me...
server = function(input, output, session) {
output$table <-renderExcel(
excelTable(
data = iris,
autoColTypes = FALSE,
fullscreen = FALSE,
tableHeight = 500,
lazyLoading = TRUE,
search = TRUE
)
)
}

I'm going to leave this question open for a few days to see if anyone has a better answer.
For now, I managed to hack a solution by changing the excelTable function.
I added the line paramList$tableHeight <- "500px" to the function, and renamed the function excelTable2.
I found this param on the website for jExcel: jExcel Parameters
I guess I will probably add the height as an input parameter to excelTable2.
excelTable2 = function (data = NULL, columns = NULL, colHeaders = NULL, rowHeight = NULL,
nestedHeaders = NULL, defaultColWidth = NULL, minDimensions = NULL,
columnSorting = TRUE, columnDrag = FALSE, columnResize = TRUE,
rowResize = FALSE, rowDrag = TRUE, editable = TRUE, allowInsertRow = TRUE,
allowInsertColumn = TRUE, allowDeleteRow = TRUE, allowDeleteColumn = TRUE,
allowRenameColumn = TRUE, allowComments = FALSE, wordWrap = FALSE,
selectionCopy = TRUE, mergeCells = NULL, search = FALSE,
pagination = NULL, fullscreen = FALSE, lazyLoading = FALSE,
loadingSpin = FALSE, style = NULL, autoColTypes = TRUE, showToolbar = FALSE,
dateFormat = "DD/MM/YYYY", digits = 4, autoWidth = TRUE,
autoFill = FALSE, getSelectedData = FALSE, ...)
{
paramList <- list()
if (!is.null(data)) {
if (is.data.frame(data) || is.matrix(data)) {
paramList$data <- jsonlite::toJSON(data, dataframe = "values",
na = "null", digits = digits)
}
else {
stop("'data' must be either a matrix or a data frame, cannot be ",
class(data))
}
}
if (is.null(columns) && is.null(colHeaders)) {
if (!is.null(data)) {
warning("Since both column title and colHeaders are not specified 'data' column name will be used as column headers")
paramList$colHeaders = colnames(data)
}
}
else if (is.null(columns) && !is.null(colHeaders)) {
if (!is.vector(colHeaders)) {
stop("'colHeaders' must be a vector, cannot be ",
class(colHeaders))
}
if (!is.null(data)) {
if (ncol(data) != length(colHeaders)) {
stop("length of 'colHeader' should be equal the number of columns in the 'data', 'data' has ",
ncol(data), "but the length of 'colHeader' is ",
length(colHeaders))
}
}
paramList$colHeaders <- jsonlite::toJSON(colHeaders)
}
else if (!is.null(columns)) {
if (!is.data.frame(columns)) {
stop("'columns' must be a dataframe, cannot be ",
class(columns))
}
if (!is.null(data)) {
if (nrow(columns) != ncol(data)) {
stop("number of rows in 'columns' should be equal to number of columns in 'data', expected number of rows in 'columns' to be ",
ncol(data), " but got ", nrow(columns))
}
}
if (!"title" %in% colnames(columns)) {
if (is.null(colHeaders)) {
if (!is.null(data)) {
warning("Since both column title and colHeaders are not specified 'data' column name will be used as column headers")
paramList$colHeaders = jsonlite::toJSON(colnames(data))
}
}
else {
paramList$colHeaders = jsonlite::toJSON(colHeaders)
}
}
paramList$columns <- jsonlite::toJSON(columns)
}
if (autoColTypes && !is.null(data)) {
if (is.null(columns)) {
message("Since 'type' attribute is not specified and autoColTypes is true, detecting type from 'data'")
colTypes <- get_col_types(data)
columns <- data.frame(type = colTypes)
columns <- add_source_for_dropdown_type(data, columns)
paramList$columns <- jsonlite::toJSON(columns)
}
else {
if (!"type" %in% colnames(columns) && autoColTypes) {
message("Since 'type' attribute is not specified and autoColTypes is true, detecting type from 'data'")
colTypes <- get_col_types(data)
columns$type <- colTypes
columns <- add_source_for_dropdown_type(data,
columns)
paramList$columns <- jsonlite::toJSON(columns)
}
}
}
if (!is.null(rowHeight)) {
if (!is.data.frame(rowHeight) && !is.matrix(rowHeight)) {
stop("'rowHeight' must either be a matrix or a dataframe, cannot be ",
class(rowHeight))
}
if (ncol(rowHeight) != 2) {
stop("'rowHeight' must either be a matrix or a dataframe with two columns, but got ",
ncol(rowHeight), " column(s)")
}
paramList$rowHeight <- jsonlite::toJSON(rowHeight, dataframe = "values")
}
if (!is.null(nestedHeaders)) {
if (!is.list(nestedHeaders)) {
stop("'nestedHeaders' must be a list of dataframe(s), cannot be ",
class(nestedHeaders))
}
headerAttributes <- c("title", "colspan")
for (nestedHeader in nestedHeaders) {
if (!is.data.frame(nestedHeader)) {
stop("'nestedHeaders' must be a list of dataframe(s), but got list of ",
class(nestedHeader), "(s)")
}
if (ncol(nestedHeader) < 2 || nrow(nestedHeader) <
1) {
stop("the dataframe(s) in 'nestedHeaders must contain at least two columns and one row, 'title' and 'colspan', but got only ",
ncol(nestedHeader), " column and ", nrow(nestedHeader),
" row")
}
if (!"title" %in% colnames(nestedHeader)) {
stop("one of the column in the dataframe in list of 'nestedHeaders' should have 'title' as header which will be used as title of the nested header")
}
if (!"colspan" %in% colnames(nestedHeader)) {
stop("one of the column in the dataframe in list of 'nestedHeaders' should have 'colspan' as header which will be used to determine the number of column it needs to span")
}
if (!all(colnames(nestedHeader) %in% headerAttributes)) {
warning("unknown headers(s) ", colnames(nestedHeader)[!colnames(nestedHeader) %in%
headerAttributes], " for 'nestedHeader' found, ignoring column with those header(s)")
}
}
paramList$nestedHeaders <- jsonlite::toJSON(nestedHeaders,
dataframe = "rows")
}
if (!is.null(defaultColWidth)) {
if (!is.numeric(defaultColWidth) || length(defaultColWidth) >
1) {
stop("'defaultColWidth' must be a numeric value of length 1 but got ",
class(defaultColWidth), " of length ",
length(defaultColWidth))
}
paramList$defaultColWidth <- defaultColWidth
}
if (!is.null(minDimensions)) {
if (!is.vector(minDimensions)) {
stop("'minDimensions' must be vector but got ",
class(minDimensions))
}
if (length(minDimensions) != 2) {
stop("'minDimensions' must be a vector of length of 2 but got length of ",
length(minDimensions))
}
paramList$minDimensions <- minDimensions
}
for (arg in c("columnSorting", "columnDrag",
"columnResize", "rowResize", "rowDrag",
"editable", "allowInsertRow", "allowInsertColumn",
"allowDeleteRow", "allowDeleteColumn", "allowRenameColumn",
"allowComments", "wordWrap", "selectionCopy",
"search", "fullscreen", "lazyLoading",
"loadingSpin", "showToolbar", "autoWidth",
"autoFill", "getSelectedData")) {
argvalue <- get(arg)
if (!is.null(argvalue)) {
if (is.logical(argvalue)) {
paramList[[arg]] <- argvalue
}
else {
warning("Argument ", arg, " should be either TRUE or FALSE. Ignoring ",
arg, ".", call. = FALSE)
paramList[[arg]] <- NULL
}
}
}
if (!is.null(mergeCells)) {
if (!is.list(mergeCells)) {
stop("expected 'mergeCells' to be a list but got ",
class(mergeCells))
}
for (mergeCell in mergeCells) {
if (!is.vector(mergeCell)) {
stop("expected each parameter in 'mergeCells' list to be a vector but got ",
class(mergeCell))
}
if (length(mergeCell) != 2) {
stop("expected each parameter in 'mergeCells' list to be a vector of length 2 but got vector of length ",
length(mergeCells))
}
}
paramList$mergeCells <- mergeCells
}
if (!is.null(pagination)) {
if (!is.numeric(pagination) || length(pagination) > 1) {
stop("'pagination' must be an integer of length 1 but got ",
class(pagination), " of length ", length(pagination))
}
paramList$pagination <- pagination
}
if (!is.null(style)) {
if (!is.list(style)) {
stop("'style' should be a list but got ", class(style))
}
paramList$style <- style
}
if (!is.null(dateFormat)) {
paramList$dateFormat <- dateFormat
}
paramList$tableHeight <- "500px"
paramList <- append(paramList, list(...))
htmlwidgets::createWidget(name = "jexcel", x = paramList,
width = if (fullscreen)
"100%"
else 0, height = if (fullscreen)
"100%"
else 0, package = "excelR",
)
}
Working app after defining above excelTable2
shinyApp(
ui = navbarPage("title", selected = "main",
position = "fixed-top",
tags$style(type="text/css", "body {padding-top: 70px;}"),
tabPanel("main", id = "main",
fluidPage(
excelOutput("table", width = "100%", height = "100%")
#htmlOutput("table", width = "100%", height = "500px")
)
)
),
server = function(input, output, session) {
output$table <-renderExcel(
excelTable2(
data = iris,
autoColTypes = FALSE,
autoFill = TRUE,
fullscreen = FALSE,
lazyLoading = TRUE,
search = TRUE
)
)
}
)

Related

Fixed colums can't Align other colums

I use DT::data.table in my shiny app, but the fixed colums can't match other cols.
It's my ui and server code:
Ui.R
DT::dataTableOutput("mytable2")
Server.R:
output$mytable2 <- DT::renderDT({
IDNAME <- soya.info$Names
names(IDNAME) <- soya.info$ID
IDNAMEsd <- IDNAME[colnames(serchSNP)[-c(1:7)]]
colnames(serchSNP)[-c(1:7)] <- paste0(colnames(serchSNP)[-c(1:7)], " (", IDNAMEsd, ")")
DT::datatable(
serchSNP,
selection = 'none', rownames = FALSE, escape = FALSE,
extensions = c("FixedColumns","Buttons"),
options = list(
buttons = list('pageLength',
list(extend = 'csv', filename = paste("snp", sep = "-")),
list(extend = 'excel', filename = paste("snp", sep = "-")),
'copy'),dom = 'Bfrtip',
pageLength = 15, columnDefs=list(list(targets="_all", class="dt-center")),
bSort = FALSE, scrollX = TRUE, fixedColumns = list(leftColumns = 6),
initComplete = DT::JS(
"function(settings, json) {",
"$(this.api().table().header()).css({'background-color': '#676464', 'color': '#fff'});",
"}")
)
)
}, server = FALSE)
My app in https://venyao.xyz/SoybeanGDB/,
In page SNPs - Search

How to add arguments to a DT:datatable based on some if conditions?

I am trying to format a table in shiny using DT::datatable. All my tables can have the default container but only when I pass the container argument that is when I want it to be designed as passed. I have tried multiple options of using if conditions but to no avail. WHen I looked at the datatable code, it says that if the container function is missing it takes a default type. I tried to coerce the same as well but it is still giving me an error.
Please help on this. Below is the code for the same:
table_opt = function(x, edit_y, container_dat = NULL, form_type = "", col_list = NULL){
DT::renderDataTable({
####### Percentage Format
if(form_type == "%")
{
datatable(x
,editable = edit_y
,if(is.null(container_dat)){container = expr()} else {container = container_dat}
,rownames = F
,options = list(
paging = F
,ordering = F
,searching = F
,deferRender = T
,class = "compact"
,headerCallback = JS(
"function(thead) {",
"$(thead).css('font-size','14px');",
"$(thead).css('background-color','#000000');",
"$(thead).css('color','#ffffff');",
"}"
,columnDefs = list(list(className = 'dt-center', targets = '_all'))
)) %>%
formatPercentage(col_list,digits = 2)
}
})
}
do.call should accomplish what you're trying to do.
table_opt = function(x, edit_y, container_dat = NULL, form_type = "", col_list = NULL){
DT::renderDataTable({
####### Percentage Format
if(form_type == "%")
{
dt_args <- list(data = x
,editable = edit_y
,rownames = F
,options = list(
paging = F
,ordering = F
,searching = F
,deferRender = T
,class = "compact"
,headerCallback = JS(
"function(thead) {",
"$(thead).css('font-size','14px');",
"$(thead).css('background-color','#000000');",
"$(thead).css('color','#ffffff');",
"}"
,columnDefs = list(list(className = 'dt-center', targets = '_all'))
))
)
if(!is.null(container_dat)) dt_args$container <- container_dat
do.call("datatable", dt_args) %>%
formatPercentage(col_list,digits = 2)
}
})
}

Have multiple inputs going into multiple graphs but only 3 out of the 5 are working

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.

Reactive graph dependent on multiple inputs

I have a reactive graph that takes in multiple inputs but it is dependent on all those inputs. Is there a way that the graph can take all the inputs but it isn't dependent on them all. For example if the user selects one drop down the graph will update and not need any of the other inputs but if the user adds a second input the graph will update with the 2nd input but not need the 3rd unless it is selected. Also if what the user has selected is null it won't change the graph.
UI:
ui <- dashboardPage(
dashboardHeader(title = "Human Trafficking"),
dashboardSidebar(
sidebarMenu(
selectInput("Source", "Choose a Data Source: ", choices = sort(unique(ngo$Data.Provided.By)), selected = NULL,
multiple = TRUE, selectize = TRUE, width = NULL, size = NULL),
dateInput("startdate", "Start Date:", value = "2009-01-01", format = "dd-mm-yyyy",
min = "2009-01-01", max = "2019-08-26"),
dateInput("enddate", "End Date:", value = "2019-08-27", format = "dd-mm-yyyy",
min = "2009-01-02", max = "2019-08-27"),
selectInput("Nationality", "Select a nation: ", choices = sort(unique(ngo$Victim.Nationality))),
actionButton("button", "Apply")
)
),
dashboardBody(
fluidRow(
box(width = 4, solidHeader = TRUE,
selectInput("traffickingType", "Choose a trafficking type: ", choices = sort(unique(ngo$Trafficking.Type)), selected = NULL,
multiple = TRUE, selectize = TRUE, width = NULL, size = NULL)
),
box(width = 4, solidHeader = TRUE,
selectInput("traffickingSubType", "Choose a trafficking sub type: ", choices = sort(unique(ngo$Trafficking.Sub.Type)), selected = NULL,
multiple = TRUE, selectize = TRUE, width = NULL, size = NULL)
),
box(width = 4, solidHeader = TRUE,
selectInput("gender", "Choose a gender: ", choices = sort(unique(ngo$Victim.Gender)), selected = NULL,
multiple = TRUE, selectize = TRUE, width = NULL, size = NULL)
)
),
fluidRow(
box(width = 6, solidHeader = TRUE, status = "primary",
title = "Trafficking Type",
plotlyOutput("coolplot", width = '750px', height = '600px')
),
box(width = 6, solidHeader = TRUE, status = "primary",
title = "Trafficking Sub-Type",
plotlyOutput("Sub", width = '750px', height = '600px')
)
)
)
)
Server:
server <- function(input, output, session) {
output$coolplot <- renderPlotly({
ngo <-
ngo %>%
filter(Victim.Nationality %in% input$Nationality,
Victim.Gender %in% input$gender,
Trafficking.Type %in% input$traffickingType,
Trafficking.Sub.Type %in% input$traffickingSubType,
Data.Provided.By %in% input$Source
) %>%
plot_ly(labels = ~Trafficking.Type, type = "pie")
})
}
I want to be able to allow the user to select one input and it will update graph and the more they add the graph will keep updating.
Not the neatest but what about separating the filtering as below:
server <- function(input, output, session) {
output$coolplot <- renderPlotly({
req(c(input$gender, input$traffickingType, input$traffickingSubType))
if(!is.null(input$Nationality)) {
ngo <- ngo %>% filter(Victim.Nationality %in% input$Nationality)
}
if(!is.null(input$gender)) {
ngo <- ngo %>% filter(Victim.Gender %in% input$gender)
}
if(!is.null(input$traffickingType)) {
ngo <- ngo %>% filter(Trafficking.Type %in% input$traffickingType)
}
if(!is.null(input$traffickingSubType)) {
ngo <- ngo %>% filter(Trafficking.Sub.Type %in% input$traffickingSubType)
}
if(!is.null(input$Source)) {
ngo <- ngo %>% filter(Data.Provided.By %in% input$Source)
}
plot_ly(ngo, labels = ~Trafficking.Type, type = "pie")
})
}
shinyApp(ui, server)
Update
based on comment below.
I added req(c(input$gender, input$traffickingType, input$traffickingSubType)).
I left out input$Nationality as that equals "A" on startup and input$Source I assumed but you can add input$source to the vector c(...) above if you want.

button inside. DT::datatable does not render properly

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;",
"}")