how to get the list in R shinydashboard - r

I am getting the all the text like a paragraph. I want all the text in the list format for example - li in html. Please help me in this. I tried using vector but was not able to do. That is the reason i appended each and every text using paste0 method using sep="\n" But \n is not showing up with new line.
My ui.R file is
# shinydashboard makes it easy to use Shiny to create dashboards
# shinydashboard requires Shiny 0.11 or above
#First Selecting the shiny Dashboard
library(shiny)
library(shinydashboard)
library(openxlsx)
FileNames <- list.files("ExcelSheets/")
countDays <- length(FileNames)
positive = 0
neutral = 0
negative = 0
count = 0
positiveTweets = ""
negativeTweets = ""
neutralTweets = ""
p = 1
nu = 1
ng = 1
for (i in seq(1, length(FileNames)))
{
excelSheetData = read.xlsx(paste0("ExcelSheets/", FileNames[i]), startRow = 0, colNames = TRUE, detectDates = TRUE)
countRows <- dim(excelSheetData)
countRows <- countRows[1]
rows <- countRows
count = count + rows
data = excelSheetData[, c("polarity", "polarity_confidence", "Text")]
for (j in seq(1, rows)){
if(data[j, 1] == "positive")
{
positive = positive + data[j, 2]
positiveTweets = paste0(positiveTweets, paste0(paste(paste0(p, ":"), data[j,3]), "\n"))
p = p + 1
}
else if(data[j, 1] == "negative")
{
negative = negative + data[j, 2]
negativeTweets = paste0(negativeTweets, paste0(paste(paste0(ng, ":"), data[j,3]), "\n"))
ng = ng + 1
}
else
{
neutral = neutral + data[j, 2]
neutralTweets = paste0(neutralTweets, paste0(paste(paste0(nu, ":"), data[j,3]), "\n"))
nu = nu + 1
}
}
}
total <- positive + negative + neutral
positivePercent <- round((positive * 100) / total)
negativePercent <- round((negative * 100) / total)
neutralPercent <- round((neutral * 100) / total)
countVect = c(positive, neutral, negative)
shinyUI(dashboardPage(
dashboardHeader(title = "Sentiment Analysis"),
dashboardSidebar(
sidebarMenu(
menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")),
menuItem("Tweets", icon = icon("twitter"),
menuSubItem("Positive Tweets", tabName = "pTweets", icon = icon("thumbs-up")),
menuSubItem("Neutral Tweets", tabName = "neuTweets", icon = icon("hand-spock-o")),
menuSubItem("Negative Tweets", tabName = "negTweets", icon = icon("thumbs-down"))
)
)
),
## Body content
dashboardBody(
tabItems(
# First tab content
tabItem(tabName = "dashboard",
div(class = "my-class", h2("Sentiment Analysis of Twitter Tweets using RapidMinor and Shiny Dashboard.")),
fluidRow(
valueBox(count, "Total Number of Tweets Analyzed in the competition", icon = icon("twitter"), width = 6),
valueBox(countDays, "Number of Days ", icon = icon("calendar-check-o"), width = 6, color = "yellow")
),
fluidRow(
infoBox("Positive", paste(positivePercent, "%"), icon = icon("thumbs-up"), width = 4, fill = TRUE, color = "green"),
infoBox("Neutral", paste(neutralPercent, "%"), icon = icon("hand-spock-o"), width = 4, fill = TRUE, color = "light-blue"),
infoBox("Negative", paste(negativePercent, "%"), icon = icon("thumbs-down"), width = 4, fill = TRUE, color = "red")
)
),
# Positive Tweets tab content
tabItem(tabName = "pTweets",
h2("Positive Tweets #Brexit"),
h4(positiveTweets)
),
# Neutral Tweets tab content
tabItem(tabName = "neuTweets",
h2("Neutral Tweets #Brexit"),
h4(neutralTweets)
),
# Negative Tweets tab content
tabItem(tabName = "negTweets",
h2("Negative Tweets #Brexit"),
h4(negativeTweets)
)
)
)
))
My server.R file is
# This is the server logic for a Shiny web application.
# You can find out more about building applications with Shiny here:
#
# http://shiny.rstudio.com
#
library(shiny)
library(shinydashboard)
shinyServer(function(input, output) {
})

A possible solution to your problem would be to append vectors with html tag <br>instead of "\n" (which would work fine with cat and verbatimTextOutput) and then to wrap, say, positiveTweets into HTML function like this:
h4(HTML(positiveTwe‌​ets))
You also want to display new tabs with the names of files in the current working directory.
In the example below I created a new menuItem which contains a random number of tabs which have random names.
First, in dashboardHeader I added dynamical output with an ID out1.
menuItemOutput("out1")
After that, on the server side, for testing purposes, I defined a variable my_files which contains a random number of tabs with random names. It will be updated each time you run the app.
Finally, within renderUI I defined menuItem ("Files") and placed within it a dynamical number of menuSubItems, which are generated with lapply.
output$out1 <- renderUI({ ... })
I also added a comment which tries to explain what you could do if you wanted to update a list of files in a working directory (and hence the names of tabs in the app) while the app is running.
Full example:
library(shiny)
library(shinydashboard)
#library(openxlsx)
rm(ui)
rm(server)
ui <- shinyUI(dashboardPage(
dashboardHeader(title = "Sentiment Analysis"),
dashboardSidebar(
sidebarMenu(
menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")),
menuItem("Tweets", icon = icon("twitter"),
menuSubItem("Positive Tweets", tabName = "pTweets", icon = icon("thumbs-up")),
menuSubItem("Neutral Tweets", tabName = "neuTweets", icon = icon("hand-spock-o")),
menuSubItem("Negative Tweets", tabName = "negTweets", icon = icon("thumbs-down"))
),
menuItemOutput("out1") # added
)
),
## Body content
dashboardBody(
tabItems(
# First tab content
tabItem(tabName = "dashboard",
div(class = "my-class", h2("Sentiment Analysis of Twitter Tweets using RapidMinor and Shiny Dashboard.")),
fluidRow(
#valueBox(count, "Total Number of Tweets Analyzed in the competition", icon = icon("twitter"), width = 6),
valueBox(15, "Total Number of Tweets Analyzed in the competition", icon = icon("twitter"), width = 6),
#valueBox(countDays, "Number of Days ", icon = icon("calendar-check-o"), width = 6, color = "yellow")
valueBox(10, "Number of Days ", icon = icon("calendar-check-o"), width = 6, color = "yellow")
),
fluidRow(
#infoBox("Positive", paste(positivePercent, "%"), icon = icon("thumbs-up"), width = 4, fill = TRUE, color = "green"),
infoBox("Positive", "80%", icon = icon("thumbs-up"), width = 4, fill = TRUE, color = "green"),
infoBox("Neutral", "15%", icon = icon("hand-spock-o"), width = 4, fill = TRUE, color = "light-blue"),
infoBox("Negative", "5%", icon = icon("thumbs-down"), width = 4, fill = TRUE, color = "red")
)
),
# Positive Tweets tab content
tabItem(tabName = "pTweets",
h2("Positive Tweets #Brexit"),
#h4(positiveTweets)
h4("Great")
),
# Neutral Tweets tab content
tabItem(tabName = "neuTweets",
h2("Neutral Tweets #Brexit"),
#h4(neutralTweets)
h4("ok")
),
# Negative Tweets tab content
tabItem(tabName = "negTweets",
h2("Negative Tweets #Brexit"),
#h4(negativeTweets)
h4("shit :D")
)
)
)
))
server <- function(input, output) {
#my_files will be updated each time you run the app
#my_files <- list.files()
# for testing purposes generate 5 tabs with names given by random letters
my_files <- letters[sample(1:26, 5)]
# There could also be the case when there is no files in a folder
# You can handle it with `req` or `validate(need(...))` functions
#my_files <- ""
output$out1 <- renderUI({
# Just in case if you would put new files to the folder
# while the app is working and wanted an update of tabs:
# - create eventReactive with an actionButton which will
# return list.files().
# - pass new names of files to this renderUi function.
# be careful because "tabName" must not have a "." in it.
req(my_files) # show tabs only if there are files in a directory
# generate and save tabs in a list
tabs <- lapply(seq_along(my_files), function(i) {
menuSubItem(my_files[i], tabName = my_files[i], icon = icon("thumbs-up"))
})
menuItem("Files", tabName = "Files", icon = NULL, tabs)
})
}
shinyApp(ui, server)

Related

Independent reactions are interacting in a Shiny App

I'm using the sliderInput function with the animate argument to perform an automatic calculation in my shinyApp. However, using animate is affecting other reactions in my app. I would like to stop this side effect that is occurring in other reactivities.
For example, I have a dropdownMenu inside an if else structure. But, because of the animate argument, I can't click the option in the top right corner when I start the animation. It is disappearing with each calculation that the animate is doing. See:
I tried use isolate() in pred_1() but it stop the valueBox and the conditional structure (if else structure).
I'd like to just make animate not affect other reactivity in the app.
My app:
library(shiny)
library(shinydashboard)
header <- dashboardHeader(
title = "Dashboard",
titleWidth = 300,
dropdownMenuOutput(
outputId = "drop1"
)
)
sidebar <- dashboardSidebar(
width = 300
)
body <- dashboardBody(
sliderInput(
inputId = "one",
label = "Registro 1",
value = 1,
animate = animationOptions(
interval = 500, loop = TRUE
),
min = 1,
max = 10,
step = 1,
ticks = TRUE
),
sliderInput(
inputId = "two",
label = "Registro 2",
value = 1,
animate = animationOptions(
interval = 500, loop = TRUE
),
min = 1,
max = 10,
step = 1,
ticks = TRUE
),
sliderInput(
inputId = "three",
label = "Sum 3",
value = 1,
animate = animationOptions(
interval = 500, loop = TRUE
),
min = 1,
max = 10,
step = 1,
ticks = TRUE
),
valueBoxOutput(
outputId = "box1"
)
)
ui <- dashboardPage(
header = header,
sidebar = sidebar,
body = body
)
server <- function(session, input, output) {
fx <- function(x, y) {
x + y
}
fy <- function(x) {
x
}
reac_0 <- reactive({
tibble::tibble(
one = input$one,
two = input$two,
three = input$three
)
})
chuveiro <- reactive({
temp <- reac_0()
fx(
x = temp$one,
y = temp$two
)
})
luz <- reactive({
temp <- reac_0()
fy(
x = temp$three
)
})
fdrop <- function(x) {
if (x <= 5) {
dropdownMenu(
type = "notifications",
badgeStatus = NULL,
headerText = "Not 1",
notificationItem(
text = HTML(
"<text style='color:#020202;'>Without.</text>"
),
status = "danger",
icon = icon("times"),
href = NULL
)
)
} else (
dropdownMenu(
type = "notifications",
badgeStatus = "danger",
headerText = "Not 2",
notificationItem(
text = HTML(
"<a style='color:#020202;'
href='https://www.instagram.com' target='_blank' title='A'>
With</a>"
),
status = "success",
icon = icon("tags")
)
)
)
}
output$drop1 <- renderMenu({
expr = fdrop(x = luz())
})
output$box1 <- renderValueBox({
expr = valueBox(
value = chuveiro(),
subtitle = "Sum"
)
})
}
shinyApp(ui, server)
So how can I make one reactivity effect another in a shinyApp?
I would like to click normally on the dropdownMenu notification with the sliderInput working with animate.
I tried isolating each argument of sliderInput, but not work.
The reac0() reactive is triggered whenever an input changes. Then it triggers every reactive that includes it, even if the value used in that reactive has not changed.
Your code :
reac_0 <- reactive({
tibble::tibble(
one = input$one,
two = input$two,
three = input$three
)
})
luz <- reactive({
temp <- reac_0()
fy(
x = temp$three
)
})
triggers luz() whenever one, two or three changes.
An alternative would be to use input$three directly:
luz <- reactive({
fy(
x = input$three
)
})
This way, the change or animation of slider one and two won't trigger luz() which won't trigger the menu rendering.
Of course, since the value of slider three is used to render the menu, any update of its value has to trigger the menu rendering.

Shiny Dashboard formatting issue

library(needs)
needs(
shiny,
ggplot2,
tidyverse,
shinydashboard,
DT
)
source("~/functions.R",local = T)
# Define UI for application that draws a histogram
header = dashboardHeader(
# tags$li(class = "dropdown",
# tags$style(".main-header {max-height: 80px}"),
# tags$style(".main-header .logo {height: 80px}")),
#title = tags$img(src='logo.png',height='100',width='200')
)
sidebar = dashboardSidebar(
menuItem("Full data",tabName="Data",icon=icon("table"),startExpanded = F,
fileInput("file","Upload CSV files",multiple=TRUE,accept=("text/comma"))),
menuItem(text = 'Simulate',tabName = 'simulate',icon=icon('chart-line'),
helpText('Simulation Parameters'),
radioButtons('type',"Please choose the type of analysis:",choices = list("Gender" = 1,"US Minority Status" = 2),selected = 1),
sliderInput("numSims","Number of simulations:",min = 1, max = 10000,step = 1000,value = 10000),
sliderInput("numYears","Number of years to simulate:",min = 1,max = 5,value = 3,step = 1),
numericInput('turnover','Total Turnover', value = 10),
sliderInput('promoRate','Set Promo rate', value = 25, min = 1, max = 100, step = 5),
sliderInput('growthRate','Set growth rate',value = 0,min=0,max=100,step = 1),
helpText('0% Growth Rate assumes a flat, constant headcount'),
actionButton('go',label = "Update"),width = 4)
)
body <- dashboardBody(
tabItems(
tabItem(
tabName = 'data',
fluidRow(wellPanel(
fileInput(
inputId = 'file',
label = "File Upload:",
accept = c("csv", ".csv")))),
wellPanel(DT::dataTableOutput('table'))),
tabItem(
tabName = 'simulate',
fluidRow(
wellPanel(
DT:::dataTableOutput('simDataTable')
))
)
))
ui = shinydashboard::dashboardPage(header,sidebar,body,skin='red')
server = server <- function(input, output) {
options(shiny.maxRequestSize = 30 * 1024 ^ 2)
dataset <- reactive({
req(input$file)
read.csv(input$file$datapath)
})
output$table = renderDataTable(dataset(), filter = 'top',options = list(scrollX = TRUE))
simulate = eventReactive(input$go,{
req(input$numSims,input$type)
x = dataset()
temp = dataSim(x,type=input$type,
numSims = input$numSims)
})
simulateAvg = reactive({
x = simulate()
y = x %>% group_by(Role) %>% summarise(mean(freq))
})
output$simDataTable = renderDataTable(simulateAvg())
}
shinyApp(ui,server)
I'm having some trouble with two issues.
1.) The formatting of the shiny dashboard is odd. The text on the side bar seems very compacted and not what other shiny dashboards look like. I'm not sure what the issue is.
2.) After upload, a table is suppose to appear on the dashboard body but it doesn't
3.) Once a table appears and I head to the simulate tab, will the dashboard body change accordingly and display the simulateAvgData set that I populated?
The dataSim function is from the source file on top. I don't receive any errors when I run anything so looking for guidance and inputs to whether or not this shiny dashboard work as intended. I'm newer to the dashboard packages from shiny.
You have a couple of issues here. You do not need a fileInput statement inside dashboardBody. Next, within dashboardSidebar, you can define fileInput at the top level of menuItem (option 1 in the code below), or a sub-level of the first menuItem (option 2 below). In either case, you need to have a menuItem with a tabName where you want to display the file that was read in. Once you read the input file, you need to select the appropriate tab to see the displayed data. Try this code
header <- dashboardHeader()
### option 1: fileInput at the first menuItem level
# sidebar <- dashboardSidebar(width=320,
# menuItem("Full data",tabName="Data",icon=icon("table"),startExpanded = F),
# fileInput("file","Upload CSV files",multiple=FALSE,accept=c("csv", ".csv"))
# )
### option 2 - fileInput as a subitem
sidebar <- dashboardSidebar(width=320,
menuItem("Full data",tabName="noData",icon=icon("table"),startExpanded = F, ## data not displayed for this tabName
menuItem("Full_data",tabName="Data", icon=icon("table")),
fileInput("file","Upload CSV files",multiple=FALSE,accept=c("csv", ".csv")))
)
body <- dashboardBody(
tabItems(
tabItem(
tabName = 'Data',
fluidRow(DTOutput('table')))
))
ui <- shinydashboard::dashboardPage(header,sidebar,body,skin='red')
server <- function(input, output, session) {
data1 <- reactive({
req(input$file)
data <- read.csv(input$file$datapath,sep = ",", header = TRUE)
})
output$table <- renderDT(data1())
}
shinyApp(ui,server)

Issue in inserting value with rhandsontable

Thanks for taking your valuable time to pitch in into this question. :-)
I'm building a shiny app that would take user inputs through rhandsontable and save it as a .rds file for data persistence.
The code is as follows:
Global.r
library(shiny)
library(shinydashboard)
library(shinycssloaders
library(rhandsontable)
library(htmltools)
library(plotly)
library(shinyjs)
library(tidyverse)
library(DT)
# Reads the data stored already
raw_data_projects <- readRDS("Projects.rds")
# code to refresh app so as to display the newly added data
jsResetCode <- "shinyjs.reset = function() {history.go(0)}"
ui.R
dashboardPage(skin = "black",
dashboardHeader(dropdownMenuOutput("dropdownmenu"),title = "PMO Dashboard",
tags$li(div(img(src = 'TechM_logo.png',
height = "35px"),
style = "padding-top:10px; padding-bottom:10px;"),
class = "dropdown"),dropdownMenuOutput("msgOutput")) ,
dashboardSidebar(
sidebarMenu(
menuItem("Home", tabName = "home", icon = icon("home")),
menuItem("Projects", tabName = "pros", icon = icon("briefcase")),
menuItem("About Team", tabName = "teamstr", icon = icon("user-friends")),
menuItem("Training & Skills",tabName = "skills",icon = icon("book"))
)),
dashboardBody(
useShinyjs(), # Include shinyjs in the UI
extendShinyjs(text = jsResetCode),
tags$link(rel = "stylesheet", type = "text/css", href = "style_2.css"),
tabItems(
tabItem(tabName = "pros",
fluidPage(tabBox(width = "500px",
tabPanel("Metrics",
fluidRow(
valueBoxOutput("Completed", width = 3),
valueBoxOutput("WIP", width = 3),
valueBoxOutput("Delayed", width = 3),
valueBoxOutput("OnHold", width = 3)
),
fluidRow(
box(plotlyOutput("Project_category"), width = 4,solidHeader = TRUE, status = "primary", title = "Project Category", collapsible = TRUE),
box(plotlyOutput("Project_status"), width = 8,solidHeader = TRUE, status = "primary", title = "Project Status", collapsible = TRUE),
box(plotlyOutput("Complexity"), width = 4,solidHeader = TRUE, status = "primary", title = "Project Complexity", collapsible = TRUE),
box(plotlyOutput("Audits"), width = 4,solidHeader = TRUE, status = "primary", title = "Audit Status", collapsible = TRUE)
)),
tabPanel("Data",
box(withSpinner(rHandsontableOutput("Projects")), width = 12),
actionButton("saveBtnProjects", "Save Projects", icon = icon("save")),
actionButton("BtnResetProjects", "Reset Filters", icon = icon("eraser")))))
)))
server.r
shinyServer(function(input, output, session){
dt_projects <- reactive({ raw_data_projects })
vals <- reactiveValues()
output$Projects <- renderRHandsontable({
rhandsontable(dt_projects(), readOnly = FALSE, search = TRUE, selectCallback = TRUE ) %>%
hot_cols(columnSorting = TRUE, manualColumnMove = TRUE, manualColumnResize = TRUE ) %>%
hot_table(highlightRow = TRUE, highlightCol = TRUE) %>%
#hot_col("PROJECT.STATUS", renderer = text_renderer, type = "autocomplete") %>%
hot_rows(fixedRowsTop = 1)
})
# on click of button the file will be saved to the working directory
observeEvent(input$saveBtnProjects,
#write.csv(hot_to_r(input$Projects), file = "./Data/project_tracker.csv",row.names = FALSE)
saveRDS(hot_to_r(input$Projects),"Projects.rds")
)
# refresh the page
observeEvent(input$saveBtnProjects, {js$reset()})
})
So when I run the app I get the table I desire as below:
As we can see, as I was inserting values to the first column, all the other columns greyed out and I couldn't insert any values into it. Please help me with this issue.
Also please suggest if my code will display the data reactively as soon as I save the data by pressing Save Projects button.
Thanks a ton in advance!!
P.S : I have included the server code only for the table considering the length of the question leaving the code of other tabs. But still this code is reproducible.

How to make dynamic tabpanels according to number of files uploaded and render a complicated Table within the tab

I am working on an app where the user can upload either one file or multiple files of individual-level data to get analyzed.
So far if the user uploads multiple files the app combines all the files in one dataset and analyzes all of them combined. I have different outputs 2 tables and a graph.
What I am struggling to do is when the user uploads multiple files I want to keep the compiled result but I want to add dynamic tabs to each box according to the number of files uploaded to present the table/graph for that file alone.
I added a checkbox so the user checks it if they are uploading multiple files. The idea was to write an observeEvent code to insert tabs according to the number of files being uploaded, that code got complicated because I had to put the renderTable chunk within it, and it is not working.
So my question is, is there a better way of doing what I am trying to do? and If my idea makes sense what is wrong with my code and why isn't it working? Thank you
Here is a sample of the code;
library(shiny)
library(dplyr)
library(shinydashboard)
library(tidyr)
library(shinyjs)
ui <- dashboardPage(
dashboardHeader(title = "Treatment and Care Cascade",
titleWidth = 300),
#Sidebar contents (tabs)
dashboardSidebar(
sidebarMenu(
menuItem("HIV Cascade", tabName = "hiv")
)),
#Main panel for displaying outputs
dashboardBody(
tabItems(
#First tab content
tabItem(tabName = "hiv",
h2("HIV Treatment and Care Cascade"),
fluidRow(
#Input: Select a file for hcv data
box(fluidRow(
box(fileInput("dt_hiv","Choose CSV File",
multiple = TRUE,
accept = c("text/csv",
"text/comma-separated-values,tesxt/plain",".csv")),width = 12,solidHeader = TRUE, height = 75),
#Input: Checkbox if file has header
box(checkboxInput("multiplehiv", "Uploading multiple files",TRUE),width = 3,solidHeader = TRUE, height = 50)), width = 12, height = 255),
#Outputs
tabBox(id = "hivcasbox", tabPanel(id = "tab1", title ="HIV Cascade",tableOutput("hivcascade"))),
box(tableOutput("hivCascadeduration"), title = "HIV Cascade - duration", solidHeader = TRUE)
))
)))
server <- function(input, output){
#Combining the datasets together
dthiv <- reactive({req(input$dt_hiv)
rbindlist(lapply(input$dt_hiv$datapath, fread, header = input$hivheader, quote = input$hivquote, sep = input$hivsep),
use.names = TRUE, fill = TRUE)
})
#The analysis chunk
cascade_hiv <- reactive({dthiv() %>% summarize("Diagnosed" = sum(hiv_posresult,na.rm = T),
"Linkage to care" = sum(linkagetocare_hiv,na.rm = T))})
cascade_hiv1 <- reactive({as.data.frame(t(cascade_hiv()))})
Percentage <- reactive({(round((cascade_hiv1()$V1*100/cascade_hiv1()$V1[1]),1))})
cascade_hiv3 <- reactive({cbind(cascade_hiv1(),Percentage())})
cascade_hiv4 <- reactive({cascade_hiv3() %>% rename(Total = V1, Percentage = "Percentage()")})
output$hivcascade <- renderTable({
cascade_hiv5 <- as.data.frame(cascade_hiv4())
rownames(cascade_hiv5) <- c("Diagnosed","Linkage to care")
cascade_hiv5},include.rownames = TRUE)
observeEvent(input$multiplehiv, {
for (i in 1:length(input$dt_hiv$datapath)) {
insertTab(inputId = "hivcasbox",
tabPanel(paste("Region",i), renderTable({
dthiv_r <- input$dt_hiv$datapath[i] %>% summarize("Diagnosed" = sum(hiv_posresult,na.rm = T),
"Linkage to care" = sum(linkagetocare_hiv,na.rm = T))
cascade_hiv1_r <- as.data.frame(t(dthiv_r))
Percentage_r <- round((cascade_hiv1_r$V1*100/cascade_hiv1_r$V1[1]),1)
cascade_hiv3_r <- cbind(cascade_hiv1_r,Percentage_r)
cascade_hiv4_r <- cascade_hiv3_r %>% rename(Total = V1, Percentage = "Percentage_r")
cascade_hiv5_r <- as.data.frame(cascade_hiv4_r)
rownames(cascade_hiv5_r) <- c("Diagnosed","Linkage to care")
cascade_hiv5_r},include.rownames = FALSE)),
target = "tab1")
}
})
}
shinyApp(ui, server)
Created on 2019-08-01 by the reprex package (v0.3.0)
the app runs but when I check the multiple files box, no tabs get inserted
I couldn't get the above code to work but I found another one that works using "str and eval(parse(text = str))",
however, it is not the most elegant or concise code, so I would appreciate it if someone has a better way of doing it. Thank you!
ibrary(shiny)
library(dplyr)
library(shinydashboard)
library(tidyr)
library(shinyjs)
library(data.table)
ui <- dashboardPage(
dashboardHeader(title = "Treatment and Care Cascade",
titleWidth = 300),
dashboardSidebar(
sidebarMenu(
menuItem("HIV Cascade", tabName = "hiv")
)),
dashboardBody(
tabItems(
#First tab content
tabItem(tabName = "hiv",
h2("HIV Treatment and Care Cascade"),
fluidRow(
#Input: Select a file for hcv data
box(fluidRow(
box(fileInput("dt_hiv","Choose CSV File",
multiple = TRUE,
accept = c("text/csv",
"text/comma-separated-values,tesxt/plain", ".csv")),width = 12,solidHeader = TRUE, height = 75),
#actionButton("multiplehiv", "Add 'Dynamic' tab"),
#Input: Checkbox if file has header
box(checkboxInput("multiplehiv", "Uploading multiple files",FALSE),
width = 3,solidHeader = TRUE, height = 50)
), width = 12, height = 255),
#Outputs
uiOutput("tabs")
))
)))
server <- function(input, output){
dthiv <- reactive({req(input$dt_hiv)
rbindlist(lapply(input$dt_hiv$datapath, fread),
use.names = TRUE, fill = TRUE)
})
cascade_hiv <- reactive({dthiv() %>% summarize("Diagnosed" = sum(hiv_posresult,na.rm = T),
"Linkage to care" = sum(linkagetocare_hiv,na.rm = T))})
cascade_hiv1 <- reactive({as.data.frame(t(cascade_hiv()))})
Percentage <- reactive({(round((cascade_hiv1()$V1*100/cascade_hiv1()$V1[1]),1))})
cascade_hiv3 <- reactive({cbind(cascade_hiv1(),Percentage())})
cascade_hiv4 <- reactive({cascade_hiv3() %>% rename(Total = V1, Percentage = "Percentage()")})
n_files <- reactive({length(input$dt_hiv$datapath)})
output$tabs <- renderUI({
if (input$multiplehiv == 1) {
str <- "tabBox(id = 'hivcasbox',
tabPanel(id = 'taball', title = 'HIV Cascade' ,tableOutput('hivcascade')),"
for (i in 1:n_files()) {str <- paste0(str, "tabPanel(id = paste('tab', ",i,") , title = paste('Data', ",i,") , tableOutput('hivcascader_",i,"')),")}
str <- gsub(",$",")",str)
eval(parse(text = str))
}
else {
tabBox(id = "hivcasbox",
tabPanel(id = "tab1", title = "HIV Cascade",tableOutput("hivcascade")))
}
})
output$hivcascade <- renderTable({
cascade_hiv5 <- as.data.frame(cascade_hiv4())
rownames(cascade_hiv5) <- c("Diagnosed","Linkage to care")
cascade_hiv5},include.rownames = TRUE)
dt_files <- reactive({lapply(input$dt_hiv$datapath[1:n_files()],read.csv)})
observe({
for (i in 1:n_files())
{str1 <- paste0("dthiv_r_",i,"<- reactive({dt_files()[[",i,"]] %>% summarize('Diagnosed' = sum(hiv_posresult,na.rm = T),
'Linkage to care' = sum(linkagetocare_hiv,na.rm = T))})
cascade_hiv1_r_",i,"<- reactive({as.data.frame(t(dthiv_r_",i,"()))})
Percentage_r_",i,"<- reactive({round((cascade_hiv1_r_",i,"()$V1*100/cascade_hiv1_r_",i,"()$V1[1]),1)})
cascade_hiv3_r_",i," <- reactive({cbind(cascade_hiv1_r_",i,"(),Percentage_r_",i,"())})
cascade_hiv4_r_",i,"<- reactive({cascade_hiv3_r_",i,"() %>% rename(Total = V1, Percentage = 'Percentage_r_",i,"()')})")
eval(parse(text = str1))}
for (i in 1:n_files()) {
str2 <- paste0("output$hivcascader_",i," <- renderTable({
cascade_hiv5_r_",i," <- as.data.frame(cascade_hiv4_r_",i,"())
rownames(cascade_hiv5_r_",i,") <- c('Diagnosed','Linkage to care')
cascade_hiv5_r_",i,"},include.rownames = TRUE)")
eval(parse(text = str2))}
})
}
shinyApp(ui, server)

changing body in R shiny when I change menu item

I am trying to make the body change as I select different player names.
Here I defined my lists and matrix
nametext <- list(c(“roger” , “rafa” , “marat”))
bodytext <- list(c(“roger text”, “rafa text”, “marat text”))
titletext <- list(c(“The GOAT” , “The Toro”, “My Idol”))
alldata <- data.frame( nametext , bodytext, titletext)
In the next step I set up the dashboard page, including the sidebar menu
ui <- dashboardPage(
dashboardHeader(title = “Best Players in Tennis History”,
titleWidth = 300 #because the title is too long i had to increase the width of the header
),
dashboardSidebar(
width = 300, #to match the width of the header with the sidebar
sidebarMenu(id = “player”,
menuItem(“Roger Federer”, tabName = 1, icon = icon(“user”)),
menuItem(“Rafael Nadal”, tabName = 2, icon = icon(“flash”)),
menuItem(“Marat Safin”, tabName = 3, icon = icon(“fire”))
)
),
I defined the names of the tabs as numbers 1-3. This was done with the objective of dynamically taking the data for the body from the alldata matrix.
So I add this piece of code to the dashboard body:
dashboardBody(
#Roger Federer Tab
box( print( alldata[ input&player , 2]),
title = print( alldata[ input&player ,3]),
solidHeader = TRUE,
width = 12,
height = 300
)
and I keep getting an error saying…
ERROR: object 'input' not found
This is all the code
nametext <- list(c(“roger” , “rafa” , “marat”))
bodytext <- list(c(“roger text”, “rafa text”, “marat text”))
titletext <- list(c(“The GOAT” , “The Toro”, “My Idol”))
alldata <- data.frame( nametext , bodytext, titletext)
ui <- dashboardPage(
dashboardHeader(title = “Best Players in Tennis History”,
titleWidth = 300 #because the title is too long i had to increase the width of the header
),
dashboardSidebar(
width = 300, #to match the width of the header with the sidebar
sidebarMenu(id = “player”,
menuItem(“Roger Federer”, tabName = 1, icon = icon(“user”)),
menuItem(“Rafael Nadal”, tabName = 2, icon = icon(“flash”)),
menuItem(“Marat Safin”, tabName = 3, icon = icon(“fire”))
)
),
dashboardBody(
#Roger Federer Tab
box( print(alldata[ input&player , 2]),
title = print(alldata[ input&player ,3]),
solidHeader = TRUE,
width = 12,
height = 300
)
)
)
server <- function(input, output) {
}
shinyApp(ui, server)

Resources