Can we add a small icon next to values in DT table. Example
if (interactive()) {
library(shiny)
library(shinyWidgets)
library(DT)
ui <- fluidPage(
tags$h3("Material switch examples"),
fluidRow(column(width = 12),
fluidRow(box(width = 4, dateInput("date","Date", value = Sys.time(), min = Sys.time(), max = Sys.time()-30)),
box(width = 7, selectInput("df","DF",choices = unique(iris$Species)),offset = 0),
box(width = 2, actionButton("ab","Action")))),
dataTableOutput("df")
)
server <- function(input, output) {
output$df <- DT::renderDataTable({
datatable(head(iris),caption = "Iris",options = list(dom = 'ft'))
})
}
shinyApp(ui, server)
}
IN the above DT table, can we add upward arrow next to Setosa . (It should be clickable)
Expect Output
You could use icon to display an up arrow.
library(shiny)
library(shinyWidgets)
library(DT)
library(dplyr)
ui <- fluidPage(
tags$h3("Material switch examples"),
dataTableOutput("df")
)
server <- function(input, output) {
data <- head(iris) %>% mutate(Species = paste(Species,as.character(icon("arrow-up", lib = "glyphicon"))))
output$df <- DT::renderDataTable({
datatable(data,caption = "Iris",options = list(dom = 'ft'),escape=FALSE, selection = list(mode = 'single',target = 'cell'))
})
}
shinyApp(ui, server)
Related
Please see attached image. Do you have suggestions how to avoid that the plot is outside the white area, or to make the grey area below the plot white?
ui <- dashboardPage(
# Application title
dashboardHeader(title=h4(HTML("Virus Coverage plot"))),
dashboardSidebar(
useShinyjs(),
selectInput("Taxa", "Taxa", choices = unique(files.Vir.DNA.df.test$V1))
),
dashboardBody(
tabsetPanel(
tabPanel("Taxa", plotOutput("myplot1"))
)
)
)
server <- function(input, output, session) {
data_selected <- reactive({
filter(files.Vir.DNA.df.test, V1 %in% input$Taxa)
})
output$myplot1 <- renderPlot({
#data_selected() %>%
# filter(Cancer=="Anus" | Cancer=="Cervix") %>%
p <- ggplot(data_selected(),aes(position,rowSums, fill = V1)) +
#theme_bw(base_size = 6) +
geom_bar(stat="identity") +
facet_grid(Cancer~. , scales = "free_x", space = "free_x", switch = "x") +
theme(strip.text.y = element_text(angle = 0),
strip.text.x = element_text(angle = 90),
strip.background = element_rect(colour = "transparent", fill = "transparent"),
plot.background = element_rect(colour = "white", fill = "white"),
panel.background = element_rect(colour = "white", fill = "white"),
axis.text.x = element_blank(),
axis.ticks.x = element_blank()) +
labs(y="Sum coverage within cancer type", x="", title="") +
scale_fill_manual(values=mycolors) +
theme(legend.position = "none")
#scale_y_log10()
print(p)
},res = 100,width = 600, height = 1200)
}
shinyApp(ui, server)
Your example isn't reproducible - so I made a new one.
You just need to wrap the plotOutput in a fluidRow:
library(shiny)
library(ggplot2)
library(datasets)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
# dashboardBody(plotOutput("myplot")) # exceeds body
dashboardBody(fluidRow(plotOutput("myplot"))) # works
)
server <- function(input, output, session) {
output$myplot <- renderPlot({
scatter <- ggplot(data=iris, aes(x = Sepal.Length, y = Sepal.Width))
scatter + geom_point(aes(color=Species, shape=Species)) +
xlab("Sepal Length") + ylab("Sepal Width") +
ggtitle("Sepal Length-Width")
}, height = 1200)
}
shinyApp(ui, server)
So a plotly plot has an embedded rangeslider however I do not like the looks of it. The rangeslider in R Shiny looks much better and professional, however how do i connect the two?
Lets say you have a dataframe with some values and a daterange like:
library(lubridate)
df <- data.frame(
"Date" = c(seq(ymd('2015-09-15'), ymd('2015-09-24'), by = "1 days")),
"values" = c(3,6,5,3,5,6,7,7,4,2)
)
Code for the plotly plot
library(plotly)
plot_df <- plot_ly(df)
plot_df <- plot_df %>% add_lines(type = 'scatter', mode = "lines",
x = ~Date, y = ~values)
Code Shiny
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Basic dashboard"),
dashboardSidebar(),
dashboardBody(
# Boxes need to be put in a row (or column)
fluidRow(
box(plotlyOutput("plotdf", height = 250)),
box(
title = "Controls",
sliderInput("Date", "", min = df$Date[1], tail(df$Date, 1), value = tail(df$Date, 1)
)
)
)
)
)
server <- function(input, output) {
output$plotdf<-renderPlotly({
plot_df
})
}
shinyApp(ui, server)
We can use dplyr::filter and pipe it to plot_ly().
output$plotdf<-renderPlotly({
filter(df, Date <= input$Date) %>%
plot_ly() %>%
add_lines(type = 'scatter', mode = "lines",
x = ~Date, y = ~values)
})
Edit: Below is the plot code separated from the app with a sliderInput to select a range of dates.
library(shiny)
library(dplyr)
library(lubridate)
library(plotly)
source(file = 'my_functions_script.R', local = TRUE)
df <- data.frame(
"Date" = c(seq(ymd('2015-09-15'), ymd('2015-09-24'), by = "1 days")),
"values" = c(3,6,5,3,5,6,7,7,4,2)
)
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Basic dashboard"),
dashboardSidebar(),
dashboardBody(
# Boxes need to be put in a row (or column)
fluidRow(
box(plotlyOutput("plotdf", height = 250)),
box(
title = "Controls",
shiny::sliderInput("Date", "", min = df$Date[1], tail(df$Date, 1), value = c(df$Date[1],tail(df$Date, 1))
)
)
)
)
)
server <- function(input, output) {
output$plotdf<-renderPlotly({
filter(df,Date >= input$Date[[1]], Date <= input$Date[[2]]) %>%
plt()
})
}
shinyApp(ui, server)
Is there a way to reduce the empty space further between widgets as shown below. Reducing space between Date and DF
if (interactive()) {
library(shiny)
library(shinyWidgets)
library(DT)
ui <- fluidPage(
tags$h3("Material switch examples"),
fluidRow(column(width = 7),
fluidRow(box(width = 2, dateInput("date","Date", value = Sys.time(), min = Sys.time(), max = Sys.time()-30)),
box(width = 2, selectInput("df","DF",choices = unique(iris$Species))),
box(width = 2, actionButton("ab","Action")))),
dataTableOutput("df")
)
server <- function(input, output) {
output$df <- DT::renderDataTable({
datatable(head(iris),caption = "Iris",options = list(dom = 'ft'))
})
}
shinyApp(ui, server)
}
You could do this by setting the CSS of the two col-sm-2 class to remove (or decrease) the padding-left and padding-right attributes. The problem is that you may want to add back in the left padding on the date box and the right padding on the df box. You could do that this way:
library(shiny)
library(shinyWidgets)
library(shinydashboard)
library(DT)
ui <- fluidPage(
tags$h3("Material switch examples"),
tags$style("
.col-sm-2{
padding-right: 0;
padding-left: 0;
}
#date{
padding-left: 25px;
}
#df{
padding-right: 15px;
}
"),
fluidRow(column(width = 7),
fluidRow(box(width = 2, dateInput("date","Date", value = Sys.time(), min = Sys.time(), max = Sys.time()-30)),
box(width = 2, selectInput("df","DF",choices = unique(iris$Species))),
box(width = 2, actionButton("ab","Action")))),
dataTableOutput("df")
)
server <- function(input, output) {
output$df <- DT::renderDataTable({
datatable(head(iris),caption = "Iris",options = list(dom = 'ft'))
})
}
shinyApp(ui, server)
Can we display toggle button next to Iris title as shown below
Below is the code for this
if (interactive()) {
library(shiny)
library(shinyWidgets)
library(DT)
ui <- fluidPage(
tags$h3("Material switch examples"),
materialSwitch(inputId = "switch1", label = "Night mode"),
dataTableOutput("df")
)
server <- function(input, output) {
output$df <- DT::renderDataTable({
datatable(head(iris),caption = "Iris",options = list(dom = 'ft'))
})
}
shinyApp(ui, server)
}
You could use a fluidRow instead of the caption option:
if (interactive()) {
library(shiny)
library(shinyWidgets)
library(DT)
ui <- fluidPage(
tags$h3("Material switch examples"),
fluidRow(column(2,tags$h4("Iris")),column(10,materialSwitch(inputId = "switch1", label = "Night mode"))),
dataTableOutput("df")
)
server <- function(input, output) {
output$df <- DT::renderDataTable({
datatable(head(iris),options = list(dom = 'ft'))
})
}
shinyApp(ui, server)
}
I have tried this in different ways and achieved one task, either add or delete., but i couldn't get complete solution in one, i might be missing some small concept somewhere.. I am adding the code , please help me complete my basic app.
library(shiny)
library(DT)
x<- data.frame(v1 = NA,
v2 = NA
),
ui = shinyUI(
fluidPage(
sidebarLayout(
sidebarPanel(
textInput("v1","v1","a"),
numericInput("V2","V2","1"),
# Row selection
numericInput(inputId = "row.selection", label = "Select row to be
deleted", min = 1, max = 100, value = "")
# Add button
actionButton(inputId = "add.button", label = "Add", icon =
icon("plus")),
# Delete button
actionButton(inputId = "delete.button", label = "Delete", icon =
icon("minus")),
),
mainPanel(
dataTableOutput('table')
)
)
)
),
Server side code
server = function(input, output, session) {
values <- reactiveValues()
values$df <- x
newEntry <- observe({
cat("newEntry\n")
if(input$add.button > 0) {
newRow <- data.frame(input$v1, input$v2)
isolate(values$df <- rbind(values$df,newRow))
}
})
deleteEntry <- observe({
cat("deleteEntry\n")
if(input$delete.button > 0) {
if(is.na(isolate(input$row.selection))){
values$df <- isolate(values$df[-nrow(values$df), ])
} else {
values$df <- isolate(values$df[-input$row.selection, ])
}
}
})
output$table = renderDataTable({
values$df
})
}
Try to use observeEvent rather than obser with actionbutton
and also, you have uppercase and lowercase issue with input$v2 (should be input$V2)
Try this modified code:
library(shiny)
library(DT)
x<- data.frame(v1 = NA,
v2 = NA
)
ui = shinyUI(
fluidPage(
sidebarLayout(
sidebarPanel(
textInput("v1","v1","a"),
numericInput("V2","V2","1"),
# Row selection
numericInput(inputId = "row.selection", label = "Select row to be
deleted", min = 1, max = 100, value = ""),
# Add button
actionButton(inputId = "add.button", label = "Add", icon =
icon("plus")),
# Delete button
actionButton(inputId = "delete.button", label = "Delete", icon =
icon("minus"))
),
mainPanel(
dataTableOutput('table')
)
)
)
)
server = function(input, output, session) {
values <- reactiveValues()
values$df <- x
observeEvent(input$add.button,{
cat("addEntry\n")
print(input$v1)
print(input$V2)
newRow <- data.frame(input$v1, input$V2)
colnames(newRow)<-colnames(values$df)
values$df <- rbind(values$df,newRow)
print(nrow(values$df))
})
observeEvent(input$delete.button,{
cat("deleteEntry\n")
if(is.na(input$row.selection)){
values$df <- values$df[-nrow(values$df), ]
} else {
values$df <- values$df[-input$row.selection, ]
}
})
output$table = renderDataTable({
values$df
})
}
shinyApp(ui,server)
Just run all the code above, and it should work properly.