Column headers of Shiny data table gets shifted - shiny

When I run my Shiny app, the headers of my data tables get shifted to the left. See below.Say this table is on Tab A.
The headers get aligned correctly when I click on a different tab (Tab B),then click on Tab A again. See below for the corrected headers.
Any idea what's causing it? Below is a simplified version of my code. Thanks in advance!
ui.R
library("shinythemes")
fluidPage(title = "Segmentation App", theme = shinytheme("spacelab"),
navbarPage("Segmentation", id = "allResults",
tabPanel(value='result_scorecard', title='ScoreCard',
sidebarLayout(
sidebarPanel(
h4("Select a cluster solution to profile"),
width = 3
),
mainPanel(
verticalLayout(
helpText(strong('Summary of Cluster Solutions')),
column(DT::dataTableOutput('out_best'), width = 12),
helpText(strong('ScoreCard Table')),
column(DT::dataTableOutput('out_scorecard'), width = 12)
)
)
)
),
tabPanel(value='profile', title='Profile',
verticalLayout(
column(DT::dataTableOutput('prop_by_cluster_ind'), width=10)
)
)
)
)
server.R
function(input, output, session) {
best_sols <- reactive({
A <- c(100, 101, 201)
B <- c(100, 101, 201)
C <- c(100, 101, 201)
temp <- as.matrix(cbind(A, B, C))
colnames(temp) <- c("A", "B", "C")
rownames(temp) <- c("k=1","k=2","k=3")
return(temp)
})
score_seg <- reactive({
A <- c("solution=1","solution=2","solution=3","solution=4","solution=5")
B <- c(100, 101, 201, 333, 444)
C <- c(100, 101, 201, 333, 444)
temp <- data.frame(A, B, C)
colnames(temp) <- c("A", "B", "score_seg")
return(temp)
})
profile_result_ind <- reactive({
A1 <- c("var1","var2","var3","var4","var5")
A2 <- c("var1","var2","var3","var4","var5")
B <- c(100, 101, 201, 333, 444)
C <- c(100, 101, 201, 333, 444)
temp <- data.frame(A1, A2, B, C)
colnames(temp) <- c("","","1","2")
return(temp)
})
# Table 1
output$out_best <- DT::renderDataTable({
DT::datatable(best_sols(), caption = "", rownames = TRUE, options = list(autoWidth = TRUE, scrollX = TRUE, columnDefs = list(list(width = '100px', targets = 1)), paging = FALSE, searching = FALSE), selection='none') %>% formatRound(1:5, 3)
#}
})
# Table 2
output$out_scorecard <- DT::renderDataTable({
DT::datatable(score_seg(), caption = "", rownames = F, options = list(autoWidth = TRUE, scrollX = TRUE, columnDefs = list(list(width = '200px', targets = 1)), paging = FALSE, searching = FALSE), selection='single') %>% formatRound(1:5, 3)
})
# Table 3
output$prop_by_cluster_ind <- DT::renderDataTable({
DT::datatable(profile_result_ind(), class= 'compact stripe', caption = '', rownames = F, options = list(autoWidth = TRUE, scrollX = TRUE, columnDefs = list(list(width = '300px', targets = 1), list(className = 'dt-left', targets="_all")), paging = FALSE, searching = FALSE)) %>% formatStyle(as.character(seq(1:2)))
})
}

I figured it out.
The headers will be aligned correctly if we change the autoWidth option to FALSE.

I had a table with long rownames such as you and had a similar problem with offset column names, but setting autoWidth=FALSE did not solve the problem. I discovered that it was being caused by scrollX=TRUE. I changed ScrollX=FALSE and wrapped the datatable in a div with overflow-x=TRUE to regain the scroll feature:
div(style="overflow-x:auto",renderDataTable({tableName},options=list(scrollX=FALSE))

Related

Toggle actionButton color (between Orange & Green) on click within Shiny DT and create new data frame from selected rows

I am developing a Shiny App, where the user can upload data, do some manipulations & create new df from selected rows. I have got till where I can add actionButtons per row in DT but cant make selections work. Selections work as expected if actionButtons are not included in the DT rows. What am I looking for?
1. To be able to toggle between two colors on click within each of the DT row (Orange = not selected; Green = selected, when clicked)
2. Create new data frame from selected rows of the datatable on another actionButton click (Ex: Category 01 or Category 02).
Once any of the Category 01 or Category 02 actionButton is clicked. I get this error Error: incorrect number of dimensions. As shown at the bottom of Image 2.
I have added reproducible code below.
Any help is much appreciated
As in screenshot1, actionbuttons are Orange And in screenshot2 they are Green ,
Data
data <- data.frame(Name = rep(paste("RIS", 1:20, sep = "_")),
Gender = rep(c("Male", "Female"), each = 10),
CDC = rnorm(20),
FDC = rnorm(20),
RDC = rnorm(20),
LDC = rnorm(20)
)
Example Code
library(shiny)
library(DT)
ui <- fluidPage(
titlePanel("simpleApp"),
sidebarLayout(
sidebarPanel(fileInput("file1", "Upload Input file", accept = ".csv"), width = 2,
actionButton("calc", "Calculate"),
hr(style = "border-color: red; height: 5px"),
actionButton("gen1", "Category 01"),
actionButton("gen2", "Category 02")),
mainPanel (
dataTableOutput("table"),
dataTableOutput("table2"),
dataTableOutput("select_table1"),
dataTableOutput("select_table2"))))
server <- function(input, output, session) {
addButtonColumn <- function(df, id, ...) {
f <- function(i) {
as.character(
actionButton(paste(id, i, sep = "_"), class = "btn-warning btn-sm", label = tags$strong("Select"),
onclick = 'Shiny.setInputValue(\"addPressed\", this.id, {priority: "event"})'))
}
addCol <- unlist(lapply(seq_len(nrow(df)), f))
DT::datatable(cbind(Decision = addCol, df),
escape = FALSE, filter = "top", options = list(columnDefs = list(list(targets = 1, sortable = FALSE))))
}
data <- reactive({
df <- input$file1
if(is.null(df))
return(NULL)
df <- read.csv(df$datapath, header = TRUE, sep = ",", row.names = NULL)
return(df)
})
output$table <- DT::renderDataTable(data(), options = list(paging = t, pageLength = 6))
table2 <- eventReactive(input$calc, {
df2 <- input$file1
if(is.null(df2))
return(NULL)
table2 <- data() %>%
mutate("Selection" = CDC * RDC + FDC * LDC) %>%
mutate(across(where(is.numeric), round, 3)) %>%
addButtonColumn("Button")
})
output$table2 <- DT::renderDataTable(table2(), options = list(paging = t, pageLength = 6))
select_table1 <- eventReactive(input$gen1, {
if(is.null(table2)){
return(NULL)
} else {
select_table1 <- table2()[input$table2_rows_selected,]
}
})
select_table2 <- eventReactive(input$gen2, {
if(is.null(table2)){
return(NULL)
} else {
select_table2 <- table2()[input$table2_rows_selected,]
}
})
output$select_table1 <- DT::renderDataTable(select_table1(), options = list(paging = t, pageLength = 6))
output$select_table2 <- DT::renderDataTable(select_table2(), options = list(paging = t, pageLength = 6))
}
shinyApp(ui = ui, server = server)
Some simple CSS can do it.
You called DT::datatable too early in the eventReactive. You need to call it within renderDataTable, otherwise, the render function can't recognize it properly (it can, but table2_rows_selected will not work).
df <- data.frame(Name = rep(paste("RIS", 1:20, sep = "_")),
Gender = rep(c("Male", "Female"), each = 10),
CDC = rnorm(20),
FDC = rnorm(20),
RDC = rnorm(20),
LDC = rnorm(20)
)
library(shiny)
library(DT)
ui <- fluidPage(
titlePanel("simpleApp"),
sidebarLayout(
sidebarPanel(fileInput("file1", "Upload Input file", accept = ".csv"), width = 2,
actionButton("calc", "Calculate"),
hr(style = "border-color: red; height: 5px"),
actionButton("gen1", "Category 01"),
actionButton("gen2", "Category 02")),
mainPanel (
dataTableOutput("table"),
dataTableOutput("table2"),
dataTableOutput("select_table1"),
dataTableOutput("select_table2"))),
tags$style(
'
table.dataTable tr.selected button {
background-color: green;
border-color: green;
}
'
)
)
server <- function(input, output, session) {
addButtonColumn <- function(df, id, ...) {
f <- function(i) {
as.character(
actionButton(paste(id, i, sep = "_"), class = "btn-warning btn-sm", label = tags$strong("Select"),
onclick = 'Shiny.setInputValue(\"addPressed\", this.id, {priority: "event"})'))
}
addCol <- unlist(lapply(seq_len(nrow(df)), f))
cbind(Decision = addCol, df)
}
data <- reactive({
df
})
output$table <- DT::renderDataTable(data(), options = list(paging = t, pageLength = 6))
table2 <- eventReactive(input$calc, {
df2 <- df
if(is.null(df2))
return(NULL)
data() %>%
mutate("Selection" = CDC * RDC + FDC * LDC) %>%
mutate(across(where(is.numeric), round, 3)) %>%
addButtonColumn("Button")
})
output$table2 <- DT::renderDataTable(DT::datatable(
table2(), escape = FALSE, filter = "top",
options = list(columnDefs = list(list(targets = 1, sortable = FALSE, paging = t, pageLength = 6)))
))
select_table1 <- eventReactive(input$gen1, {
if(is.null(table2)){
return(NULL)
} else {
print(input$table2_rows_selected)
select_table1 <- table2()[input$table2_rows_selected,]
}
})
select_table2 <- eventReactive(input$gen2, {
if(is.null(table2)){
return(NULL)
} else {
select_table2 <- table2()[input$table2_rows_selected,]
}
})
output$select_table1 <- DT::renderDataTable(DT::datatable(select_table1(), escape = FALSE, options = list(paging = t, pageLength = 6)))
output$select_table2 <- DT::renderDataTable(select_table2(), escape = FALSE, options = list(paging = t, pageLength = 6))
}
shinyApp(ui = ui, server = server)
Disabled your uploading part. You need to change it back.

Shiny tabPanel datatable including filter options

I have created a tabPanel and want to give the chance to filter by different variables (e.g., show All, gender (male or female), gaming frequency (never, sometimes, often). Giving a filter possibility on the right side of the table.
The tabPanel alone is working fine, however, I do not know how to add the select Input filter (a) multiple variables as well as b) used the output$data for output$mytable.
Gender <- c(2, 2, 2, 1, 2, 2, 1, 1, 1, 2, 2, 1, 2, 1, 1, 1, 2, 1, 2, 1) # 1 male, 2 female
Gaming_freq <- c(2, 3, 3, 3, 6, 4, 5, 5, 3, 5, 6, 5, 3, 3, 3, 2, 5, 6, 6, 3) # 2 = less than once a month, 3= once a month, 4 = once a week, 5 = more than once a week, 6 = daily
color_white <- c(0.14939, -0.40033, 0.638, -0.40328, -0.5725, 0.77422, 0.47419, -0.14982, 0.61388, 0.29264, 1.63992, 1.69396, -0.76722, 0.2279, 1.8937, 1.05535, -0.02912, -0.98787, -0.08184, 0.02536)
color_black_red <- c(-0.22686, 1.0993, 1.31564, 1.79799, 0.58323, -0.20128, 0.28315, 0.65687, -0.28894, 1.03393, 0.19963, -0.14561, 0.889, 1.5685, 0.15463, 0.74984, 0.42837, 1.31831, 0.82064, 1.13308)
color_black_blue <- c(-0.19905, -0.12332, -0.3628, 0.04108, -0.51553, -0.74827, -0.73246, -1.15794, -1.05443, -0.79687, -0.43895, -0.48986, -0.25574, -1.55343, -0.52319, -0.31203, -0.62926, -1.0094, -0.11217, -0.76892)
Controller_none <- c(-0.83456, -2.1176, -2.09919, -2.30543, -1.8594, -1.83014, -2.67447, -2.25647, -0.33004, 1.04676, -0.0674, -1.22428, -0.61644, -2.49707, 0.1737, -1.38711, -0.86417, -0.9775, -0.86747, -0.13341)
Controller_white <- c(0.51451, 0.49362, 1.17843, -0.03151, 1.27484, 0.74152, 0.07918, 1.18577, 0.50183, -0.1483, 0.22328, 1.1426, 0.46526, 1.94735, -0.60943, 1.02407, 0.55938, 1.10468, -0.12908, -0.00329)
Controller_red <- c(0.93577, 1.92379, 0.8746, 1.02084, 1.08547, 0.74312, 1.53032, 0.74821, -0.10777, 0.48774, 0.29206, 0.09947, 0.21528, 1.41961, 1.59125, -0.21777, 0.56455, 0.83702, 1.2306, 0.51277)
All <- rep(1, 20)
d <- as.data.frame(cbind(Gender, Gaming_freq, color_white, color_black_red, color_black_blue, Controller_none, Controller_white, Controller_red, All))
library(shiny)
library(shinythemes)
library(shinydashboard)
ui <- fluidPage(theme = shinytheme("sandstone"),
dashboardPage(skin = "red",
header = dashboardHeader(title = "Dashboard of Survey Results"),
sidebar = dashboardSidebar(
sidebarMenu(
menuItem("Overview", tabName = "overview", icon = icon("dashboard")),
menuItem("Utilities", icon = icon("th"), tabName = "utilities"),
menuItem("Importances", icon = icon("th"), tabName = "importances")
)
),
body = dashboardBody(tabItems(
tabItem(tabName = "utilities",
h2("Utilities of attribute levels"),
mainPanel(
tabsetPanel(
id = 'dataset',
tabPanel("Color", DT::dataTableOutput("mytable1")),
tabPanel("Extra Controller", DT::dataTableOutput("mytable2"))
)
)),
tabItem(tabName = "importances",
h2("Importance for attributes")
))))
)
server <- function(input, output) {
output$mytable1 <- DT::renderDataTable({
DT::datatable(round(d[,3:5], digits = 3), options = list(lengthMenu = c(5, 30, 50, 90), pageLength = 10, bFilter=0))
})
output$mytable2 <- DT::renderDataTable({
DT::datatable(round(d[,6:8], digits = 3),options = list(lengthMenu = c(5, 30, 50, 90), pageLength = 10, bFilter=0))
})
}
shinyApp(ui = ui, server = server)
Thanks in advance.
You can filter your data and wrap it in a reactive element, so you can later use it for any subsequent output plots/tables. You can read more about working with reactive expressions on Rstudio website.
Here as a demo, I get an input on the 'Gender', for further filtering the data out (I've used radio buttons but you can use your widget of choice: slider, select button, etc.)
radioButtons("gender", "filter for gender",
choices = c("One" = '1',
"Two" = '2')),
Then in the server, I use this input to filter the data based on the gender, and wrap it up in a reactive element:
filteredData <- reactive({
tempDataTable <- d %>% dplyr::filter(Gender==input$gender)
tempDataTable
})
Next you can use this reactive element containing your filtered data for generating output tables:
output$mytable1 <- DT::renderDataTable({
d <- filteredData()
DT::datatable(round(d[,3:5], digits = 3), options = list(lengthMenu = c(5, 30, 50, 90), pageLength = 10, bFilter=0))
})
You can use similar strategy to add additional filters or features, find the entire demo ui+server code here:
library(shiny)
library(shinythemes)
library(shinydashboard)
library(tidyverse)
library(DT)
ui <- fluidPage(theme = shinytheme("sandstone"),
dashboardPage(skin = "red",
header = dashboardHeader(title = "Dashboard of Survey Results"),
sidebar = dashboardSidebar(
sidebarMenu(
menuItem("Overview", tabName = "overview", icon = icon("dashboard")),
menuItem("Utilities", icon = icon("th"), tabName = "utilities"),
menuItem("Importances", icon = icon("th"), tabName = "importances")
)
),
body = dashboardBody(tabItems(
tabItem(tabName = "utilities",
h2("Utilities of attribute levels"),
mainPanel(
radioButtons("gender", "filter for gender",
choices = c("One" = '1',
"Two" = '2')),
tabsetPanel(
id = 'dataset',
tabPanel("Color", DT::dataTableOutput("mytable1")),
tabPanel("Extra Controller", DT::dataTableOutput("mytable2"))
)
)),
tabItem(tabName = "importances",
h2("Importance for attributes")
))))
)
server <- function(input, output) {
filteredData <- reactive({
tempDataTable <- d %>% dplyr::filter(Gender==input$gender)
tempDataTable
})
output$mytable1 <- DT::renderDataTable({
d <- filteredData()
DT::datatable(round(d[,3:5], digits = 3), options = list(lengthMenu = c(5, 30, 50, 90), pageLength = 10, bFilter=0))
})
output$mytable2 <- DT::renderDataTable({
d <- filteredData()
DT::datatable(round(d[,6:8], digits = 3),options = list(lengthMenu = c(5, 30, 50, 90), pageLength = 10, bFilter=0))
})
}
shinyApp(ui = ui, server = server)

r shiny: rhandsontable column automatically updating based on other user updated columns

The user selects first a value. Based on it, a rhandsontable appears with multiple, empty columns, with dropdown options - except for the last column, Type_action. This column, which is readOnly should be automatically updated based on values in columns Y and Z as follows: if the value in column Y is less than the value in column Z, Type_action should take value "Upgrade", otherwise, value "Downgrade".
Below my attempt, which fails to produce any value for the Type_action column:
library(shiny)
library(rhandsontable)
library(dplyr)
library(shinydashboard)
ui <- fluidPage( fluidRow(column(6, uiOutput("selA"))),
fluidRow(column(6, rHandsontableOutput('tbl1'))
)
)
server <- function(input, output, session){
dt0 <- data.frame( A = c("S2","S2","S2","S4","S4","S4"),
B = c("1","2","3","1","2","3"),
C = c(10,20,30,40,15,25),
D = c("A","B","C","D","E","F"))
# get the data for the selected BA
dt <- reactive(subset(dt0, A %in% input$selA))
# Render selectInput selBA
output$selA <- renderUI({
ba <- as.vector( unique(dt0$A) )
selectInput("selA","Choose BA", choices = ba)
})
DF <- data.frame("X" = c(""),
"Y" = c(""),
"Z" = c(""),
"Type_action" = c(""))
values <- reactiveValues(data = DF)
Y <- reactiveVal()
Z <- reactiveVal()
observe({
if(!is.null(input$tbl1)){
values$data <- as.data.frame(hot_to_r(req(input$tbl1)))
}
})
observeEvent(input$tbl1,{
Y(hot_to_r(input$tbl1)$Y)},
ignoreInit= TRUE
)
observeEvent(input$tbl1,{
Z(hot_to_r(input$tbl1)$Z)},
ignoreInit= TRUE
)
output$tbl1 = renderRHandsontable({
req(input$selA)
tmpTable <- rhandsontable(values$data, rowHeaders = FALSE, selectCallback = TRUE, width =
1000, height = 500) %>%
hot_table(highlightCol = TRUE, highlightRow = TRUE, stretchH = "all") %>%
hot_col(col = "X", type = "dropdown", colWidths = 90, source =
sort(unique(dt()$B))) %>%
hot_col(col = "Y", type = "dropdown", colWidths = 65, source =
sort(unique(dt()$D))) %>%
hot_col(col = "Z", type = "dropdown", colWidths = 60,source =
sort(unique(dt()$D))) %>%
hot_col(col = "Type_action", colWidths = 50, readOnly = TRUE, type = "text")
if(!is.null(input$tbl1_select$select$r) && !is.na(values$data$Y[input$tbl1_select$select$r])
&& !is.na(values$data$Z[input$tbl1_select$select$r])){
tmpTable <- hot_col(tmpTable,col = "Type_action", type = "text", colWidths = 60,
source = ifelse(as.numeric(factor(Y())) < as.numeric(factor(Z())),"u","d"))
}
tmpTable
})
}
shinyApp(ui, server)
The source argument of hot_col takes
a vector of choices for select, dropdown and autocomplete column types
it's not implemented to modify the content of a text cell (as you tried in the code above).
We can modify a text column by changing the underlying (reactive) data.frame.
Please check the following:
library(shiny)
library(rhandsontable)
library(dplyr)
library(shinydashboard)
ui <- fluidPage( fluidRow(column(6, uiOutput("selA"))),
fluidRow(column(6, rHandsontableOutput('tbl1'))
)
)
server <- function(input, output, session){
dt0 <- data.frame( A = c("S2","S2","S2","S4","S4","S4"),
B = c("1","2","3","1","2","3"),
C = c(10,20,30,40,15,25),
D = c("A","B","C","D","E","F"))
# get the data for the selected BA
dt <- reactive(subset(dt0, A %in% input$selA))
# Render selectInput selBA
output$selA <- renderUI({
ba <- as.vector( unique(dt0$A) )
selectInput("selA","Choose BA", choices = ba)
})
DF <- data.frame("X" = c(""),
"Y" = c(""),
"Z" = c(""),
"Type_action" = c(""))
values <- reactiveValues(data = DF)
Y <- reactiveVal()
Z <- reactiveVal()
observe({
if(!is.null(input$tbl1)){
values$data <- as.data.frame(hot_to_r(req(input$tbl1)))
}
})
observeEvent(input$tbl1,{
Y(hot_to_r(input$tbl1)$Y)},
ignoreInit= TRUE
)
observeEvent(input$tbl1,{
Z(hot_to_r(input$tbl1)$Z)},
ignoreInit= TRUE
)
output$tbl1 = renderRHandsontable({
req(input$selA)
tmpTable <- rhandsontable(values$data, rowHeaders = FALSE, selectCallback = TRUE, width =
1000, height = 500) %>%
hot_table(highlightCol = TRUE, highlightRow = TRUE, stretchH = "all") %>%
hot_col(col = "X", type = "dropdown", colWidths = 90, source =
sort(unique(dt()$B))) %>%
hot_col(col = "Y", type = "dropdown", colWidths = 65, source =
sort(unique(dt()$D))) %>%
hot_col(col = "Z", type = "dropdown", colWidths = 60,source =
sort(unique(dt()$D))) %>%
hot_col(col = "Type_action", colWidths = 50, readOnly = TRUE, type = "text")
if(!is.null(input$tbl1_select$select$r) && !is.na(values$data$Y[input$tbl1_select$select$r])
&& !is.na(values$data$Z[input$tbl1_select$select$r])){
values$data$Type_action <- ifelse(match(Y(), LETTERS) < match(Z(), LETTERS),"Upgrade","Downgrade")
}
tmpTable
})
}
shinyApp(ui, server)

shinyTree not rendering checkbox output

I am using shinyTree to render a data table. The following is the dataset with codes used so far:
library(shiny)
library(shinyTree)
newdat <- structure(list(RESPID = c("41000123", "41004132", "41006132",
"41007121", "41007123"), PDT_A = c(125, 66, 45, 28,
0), PDT_B = c(10, 0, 0, 0, 0), PDT_C = c(0, 0, 0, 0, 0), PDT_D = c(450,
105, 75, 192, 0), PDT_TOTAL = c(585, 171, 120, 220, 0)), .Names = c("RESPID",
"PDT_A", "PDT_B", "PDT_C", "PDT_D", "PDT_TOTAL"), row.names = c("6",
"40", "56", "59", "61"), class = "data.frame")
server <- shinyServer(function(input, output, session) {
newdata <- reactive({newdat})
output$tree <- renderTree({
sss=list('TOTAL_VALUE'= list('TOTAL_VALUE_OF_MERCHANDISE' = structure(list('PDT_TOTAL'='1001'), stopened=FALSE),
'PDT_CAT' = structure(list('PDT_TOTAL'='1002','PDT_A'='152','PDT_B'='153','PDT_C'='154','PDT_D'='155'), stopened=FALSE)
))
attr(sss[[1]],"stopened")=FALSE
sss
})
catdat <- reactive({
tree <- input$tree
unlist(get_selected(tree))
})
coldat <- reactive({
newdata()[,catdat()]
})
output$datatab <- renderDataTable({
coldat()
})
})
ui <- shinyUI(
pageWithSidebar(
headerPanel("TEST"),
sidebarPanel(
shinyTree("tree", checkbox = TRUE)
),
mainPanel(
dataTableOutput("datatab")
)
))
shinyApp(ui,server)
The tree gets generated. I have following trouble in rendering the columns through data table output:
The first branch of the tree, refers to only one column: which is not rendering in shiny. I am getting an error message undefined columns selected.
The second branch of the tree supposed to render all five columns of the table. However it renders only any four of the columns.
If i select root of the second branch, i am getting the same undefined columns selected. When I uncheck one of the branch the table with 4 columns gets rendered.
How do i render all the columns?
Is there a way where I can remove the check boxes at the branch root / nodes level?
Ad 1. You get this error because if you select the first branch of the tree, then catdat() returns a vector with "PDT_TOTAL" and "TOTAL_VALUE_OF_MERCHANDISE" and there is no such variable as "TOTAL_VALUE_OF_MERCHANDISE" in your dataset.
Ad 2. If you select all five options then catdat() returns additionally "PDT_CAT" and you have the same problem as above - there is no such variable in your dataset. (Same above - if you select all options, so "PDT_TOTAL", it returns additionally "TOTAL_VALUE_OF_MERCHANDISE")
To render all columns you could do following:
First, select dynamically variables from your dataset and then remove duplicates as catdat() returns twice "TOTAL_VALUE" when the very first option TOTAL_VALUE is selected.
There is also another issue: newdata()[,vars] returns a vector if there is only one variable selected and renderDataTable won't print anything as it works only with dataframes. To address this issue you can remove , to ensure that the subsetting returns always a dataframe - newdata()[vars]
coldat <- reactive({
vars <- catdat()
vars <- vars[!(vars %in% c("TOTAL_VALUE", "TOTAL_VALUE_OF_MERCHANDISE", "PDT_CAT"))]
vars <- unique(vars)
print(vars)
# newdata()[,vars] # If you select only one variable then this reactive returns an object of class numeric and not a data.frame
newdata()[vars] # remove "," and it will always return a data frame
})
Full example:
library(shiny)
library(shinyTree)
newdat <- structure(list(RESPID = c("41000123", "41004132", "41006132",
"41007121", "41007123"), PDT_A = c(125, 66, 45, 28,
0), PDT_B = c(10, 0, 0, 0, 0), PDT_C = c(0, 0, 0, 0, 0), PDT_D = c(450,
105, 75, 192, 0), PDT_TOTAL = c(585, 171, 120, 220, 0)), .Names = c("RESPID",
"PDT_A", "PDT_B", "PDT_C", "PDT_D", "PDT_TOTAL"), row.names = c("6",
"40", "56", "59", "61"), class = "data.frame")
server <- shinyServer(function(input, output, session) {
newdata <- reactive({newdat})
output$tree <- renderTree({
sss=list('TOTAL_VALUE'= list('TOTAL_VALUE_OF_MERCHANDISE' = structure(list('PDT_TOTAL'='1001'), stopened=FALSE),
'PDT_CAT' = structure(list('PDT_TOTAL'='1002','PDT_A'='152','PDT_B'='153','PDT_C'='154','PDT_D'='155'), stopened=FALSE)
))
attr(sss[[1]],"stopened")=FALSE
sss
})
catdat <- reactive({
tree <- input$tree
unlist(get_selected(tree))
})
coldat <- reactive({
vars <- catdat()
vars <- vars[!(vars %in% c("TOTAL_VALUE", "TOTAL_VALUE_OF_MERCHANDISE", "PDT_CAT"))]
vars <- unique(vars)
print(vars)
# newdata()[,vars] # If you select only one variable then this reactive returns an object of class numeric and not a data.frame
newdata()[vars] # remove "," and it will always return a data frame
})
output$datatab <- renderDataTable({
coldat()
})
})
ui <- shinyUI(
pageWithSidebar(
headerPanel("TEST"),
sidebarPanel(
shinyTree("tree", checkbox = TRUE)
),
mainPanel(
dataTableOutput("datatab")
)
))
shinyApp(ui,server)

Error on rcdimple when deploying to shinyapps.io

I have an application which works fine locally and I would like to deploy it to shinyapps.io. I created a directory (dataviz) and the application code is in a file called app.R. When running deployApp("dataviz") from RStudio, it starts deploying but reaches a point where it fails with the error:
** preparing package for lazy loading
Error in loadNamespace(i, c(lib.loc, .libPaths()), versionCheck = vI[[i]]) :
there is no package called ‘htmltools’
ERROR: lazy loading failed for package ‘rcdimple’
* removing ‘/usr/local/lib/R/site-library/rcdimple’
################################### End Log ###################################
Error: Unhandled Exception: Child Task 27328802 failed: Error building image: Error building rcdimple (0.1). Build exited with non-zero status: 1
Not sure what could be happening here, any help greatly appreciated.
The app.R is as so
## app.R ##
library(shinydashboard)
library(shiny)
require(htmltools)
require(htmlwidgets)
library(rcdimple) #devtools::install_github("timelyportfolio/rcdimple")
library(curl) #devtools::install_github("jeroenooms/curl")
library(plyr) # for round_any
library(rCharts)
library(ggvis)
library(reshape2)
indicators <- read.csv(curl("https://raw.githubusercontent.com/kilimba/msc-impl-R/master/dataviz/data/testindicators.csv"))
choices <- as.vector(indicators$label)
indicators$label <- as.character(indicators$label)
indicators$file <- paste("",indicators$file,"",sep="")
getHeatMapData <- function(data,indicator){
df <- data
if(indicator$rate == "Y"){
hmap_df <- aggregate(cbind(denominator,numerator) ~ year + agegrp,df,sum)
hmap_df$rate <- round((hmap_df$numerator/hmap_df$denominator)*indicator$multiplier,2)
names(hmap_df)
}else{
hmap_df <- aggregate(denominator ~ agegrp + year,df, sum)
}
hmap_df$year <- factor(hmap_df$year)
# Helps to order the y-axis labels otherwise labels appear in mixed order
hmap_df$agegrp <- factor(hmap_df$agegrp, levels = rev(as.vector(unique(hmap_df$agegrp))))
return(hmap_df)
}
getData <- function(startyr,endyear,outcome_data) {
data <- subset(outcome_data,(year >= startyr & year <= endyear))
return(data)
}
getDataByAgeGroup <-function(data,agegrp){
d <- data
a <- agegrp
selection <- subset(d,agegrp==a)
return(selection)
}
lineChart <- function(data,agegrp,indicator){
if(indicator$rate == "Y"){
selection <- data
selection$rate <- round((selection$numerator/selection$denominator)*indicator$multiplier,2)
selection$sex <- ifelse(selection$sex == 1, "MALE", "FEMALE")
max_y <- round_any(max(selection$rate), 10, f = ceiling)
min_y <- round_any(min(selection$rate), 10, f = floor)
selection <- getDataByAgeGroup(selection,agegrp)
plot <- nPlot(rate ~ year,
data = selection,
type = "lineChart",
group = "sex",
height = 250,
width = 450 )
# Explicitly set year tick values for every year
plot$xAxis(tickValues = do.call(seq, c(as.list(range(selection$year)), 1)),rotateLabels= -40,showMaxMin = "true")
plot$chart(useInteractiveGuideline = "true", transitionDuration = 500)
plot$chart(forceY = c(min_y, max_y))
plot$chart(color = c("steelblue","firebrick"))
# Add axis labels and format the tooltip
plot$yAxis(axisLabel = paste("Rate per",indicator$multiplier), width = 62)
plot$xAxis(axisLabel = "Year")
return(plot)
}else{
selection <- data
selection$sex <- ifelse(selection$sex == 1, "MALE", "FEMALE")
max_y <- round_any(max(selection$denominator), 10, f = ceiling)
min_y <- round_any(min(selection$denominator), 10, f = floor)
selection <- getDataByAgeGroup(selection,agegrp)
plot <- nPlot(denominator ~ year,
data = selection,
type = "lineChart",
group = "sex",
height = 250,
width = 450 )
# Explicitly set year tick values for every year
plot$xAxis(tickValues = do.call(seq, c(as.list(range(selection$year)), 1)),rotateLabels= -40,showMaxMin = "true")
plot$chart(useInteractiveGuideline = "true", transitionDuration = 500)
plot$chart(forceY = c(min_y, max_y))
plot$chart(color = c("steelblue","firebrick"))
# Add axis labels and format the tooltip
plot$yAxis(axisLabel = "Population", width = 62)
plot$xAxis(axisLabel = "Year")
return(plot)
}
}
# Heat Map
heatmap <- function(data,indicator){
dat <- getHeatMapData(data,indicator)
if(indicator$rate == "Y"){
dat <- rename(dat, c("agegrp" = "Age","year" = "Year", "rate" = "Rate"))
dat %>%
ggvis(~Year, ~Age, fill = ~Rate) %>%
layer_rects(width = band(), height = band()) %>%
add_relative_scales() %>%
set_options(height = 200, width = 410, keep_aspect = TRUE) %>%
add_axis("y", title="")%>%
scale_nominal("x", padding = 0, points = FALSE) %>%
scale_nominal("y", padding = 0, points = FALSE) %>%
scale_numeric("fill",range = c("lightsteelblue","red")) %>%
hide_legend("fill") %>%
add_tooltip(function(d) {
if(is.null(d)) return(NULL)
paste0(names(d), ": ", format(d), collapse = "<br />")
}
) %>%
bind_shiny("heatmap")
}else{
dat <- rename(dat, c("agegrp" = "Age","year" = "Year", "denominator" = "Count"))
dat %>%
ggvis(~Year, ~Age, fill = ~Count) %>%
layer_rects(width = band(), height = band()) %>%
add_relative_scales() %>%
set_options(height = 200, width = 410, keep_aspect = TRUE) %>%
add_axis("y", title="")%>%
scale_nominal("x", padding = 0, points = FALSE) %>%
scale_nominal("y", padding = 0, points = FALSE) %>%
scale_numeric("fill",range = c("lightsteelblue","red")) %>%
hide_legend("fill") %>%
add_tooltip(function(d) {
if(is.null(d)) return(NULL)
paste0(names(d), ": ", format(d), collapse = "<br />")
}
) %>%
bind_shiny("heatmap")
}
}
# DimpleJS pyramid
dPyramid <- function(startyear, endyear, data, colors=c("steelblue","firebrick"),indicator) {
dat <- getData(startyear,endyear,data)
if(indicator$rate == "Y"){
dat$denominator <- ifelse(dat$sex == 1, -1 * dat$denominator, 1 * dat$denominator)
dat$Gender <- ifelse(dat$sex == 1,"Male", "Female")
dat$Rate <- (dat$numerator/dat$denominator)*indicator$multiplier
max_x <- round_any(max(dat$Rate), 10, f = ceiling)
min_x <- round_any(min(dat$Rate), 10, f = floor)
dat <- rename(dat, c("agegrp" = "Age"))
d1 <- dimple(
x = "Rate",
y = "Age",
groups = "Gender",
data = dat,
type = 'bar')
d1 <- yAxis(d1, type = "addCategoryAxis", orderRule = "Age")
d1 <- xAxis(d1,type = "addMeasureAxis")
# Ensure fixed x-axis independent of year selected
d1 <- xAxis(d1, overrideMax = max_x, overrideMin = min_x)
if (!is.null(colors)){
d1 <- colorAxis(
d1,
type = "addColorAxis",
colorSeries = "sex",
palette = colors
)
}
# For storyboarding
if (endyear - startyear >= 1) {
d1 <- tack(d1, options = list( storyboard = "year" ) )
}
return(d1)
}
else{
dat$denominator <- ifelse(dat$sex == 1, -1 * dat$denominator, 1 * dat$denominator)
dat$Gender <- ifelse(dat$sex == 1,"Male", "Female")
max_x <- round_any(max(dat$denominator), 10, f = ceiling)
min_x <- round_any(min(-1*dat$denominator), 10, f = floor)
dat <- rename(dat,c("denominator" = "Count","agegrp" = "Age"))
d1 <- dimple(
x = "Count",
y = "Age",
groups = "Gender",
data = dat,
type = 'bar')
d1 <- yAxis(d1, type = "addCategoryAxis", orderRule = "Age")
d1 <- xAxis(d1,type = "addMeasureAxis")
# Ensure fixed x-axis independent of year selected
d1 <- xAxis(d1, overrideMax = max_x, overrideMin = min_x)
if (!is.null(colors)){
d1 <- colorAxis(
d1,
type = "addColorAxis",
colorSeries = "sex",
palette = colors
)
}
# For storyboarding
if (endyear - startyear >= 1) {
d1 <- tack(d1, options = list( storyboard = "year" ) )
}
return(d1)
}
}
suppressMessages(
singleton(
addResourcePath(
get_lib("nvd3")$name
,get_lib("nvd3")$url
)
)
)
ui <- dashboardPage(
dashboardHeader(title = "HealthData Viz"),
dashboardSidebar(
sidebarMenu(
menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")),
menuItem("Presentations", tabName = "widgets", icon = icon("file-powerpoint-o"))
),
tags$br(),
tags$fieldset(checkboxInput("doAnimate", "Animate Pyramid",value = TRUE),
tags$p("(Uncheck to select specific year)")),
conditionalPanel(
condition = "input.doAnimate == false",
uiOutput("choose_year")
),
uiOutput("choose_agegrp")
,
uiOutput("choose_dataset")
),
dashboardBody(
tags$head(get_assets_shiny(get_lib("nvd3"))[-3]),
tabItems(
# First tab content
tabItem(tabName = "dashboard",
fluidRow(
box(dimpleOutput("distPlot", height = 250)),
box(showOutput("distPlot2","nvd3",add_lib=F))
),
fluidRow(
#box(infoBoxOutput("informationBox")),
infoBox("About", textOutput("caption"), icon = icon("info-circle"),width = 6),
(
#uiOutput("ggvis_ui"),
box(ggvisOutput("heatmap"))
)
)
),
# Second tab content
tabItem(tabName = "widgets",
h2("Links to interactive scientific presentations will go here...")
)
)
)
)
server <- function(input, output) {
output$choose_dataset <- renderUI({
selectInput("outcome", "Select Outcome", choices, selected="Population Structure",width="95%")
})
output$choose_agegrp <- renderUI({
selectInput("agegrp", "Select Age Group",
choices = c("00-04","05-09","10-14","15-19","20-24","25-29",
"30-34","35-39","40-44","45-49","50-54",
"55-59","60-64","65-69","70-74","75-79",
"80-84","85+"), selected="00-04",width="95%")
})
#############################################################
# PYRAMID
#############################################################
observe({
if(!is.null(input$outcome)){
selected_outcome <- input$outcome
selected_indicator <- subset(indicators,indicators$label == selected_outcome)
outcome_data <- reactive({
read.csv(curl(as.character(selected_indicator$file)))
})
d <- reactive({outcome_data()})
minYear <- reactive({min(d()$year)})
maxYear <- reactive({max(d()$year)})
observe({
if(input$doAnimate){
output$distPlot <- renderDimple({
dPyramid(minYear(), maxYear(),data = outcome_data(), indicator = selected_indicator)
})
}else{
years <- as.vector(unique(outcome_data()$year))
output$choose_year <- renderUI({
selectInput("startyr", "Select Pyramid Year", years, width="95%")
})
output$distPlot <- renderDimple({
if(!is.null(input$startyr)){
startyear <- as.numeric(input$startyr)
# Start year and end year are equal we only want cross-sectional pyramid
# for a single selected year
dPyramid(startyear, startyear, data = outcome_data(),indicator = selected_indicator)
}
})
}
})
}
})
###############################################
observe({
if(!is.null(input$outcome)
& !is.null(input$agegrp)){
selected_outcome <- input$outcome
selected_indicator <- subset(indicators,indicators$label == selected_outcome)
outcome_data <- reactive({
read.csv(curl(as.character(selected_indicator$file)))
})
d <- reactive({outcome_data()})
output$caption <- renderText({
return(paste("You are currently viewing",
ifelse(selected_indicator$rate=="N",paste(input$outcome,".\n",selected_indicator$description),
paste(input$outcome,"(per",selected_indicator$multiplier,"population).\n",selected_indicator$description))))
})
################################################
# Line chart
################################################
output$distPlot2 <- renderChart2({
lineChart(outcome_data(),input$agegrp,selected_indicator)
})
#################################################
# HEATMAP
#################################################
heatmap(outcome_data(),selected_indicator)
}
})
}
shinyApp(ui, server)
Tumaini
#timelyportfolio - It seems dependencies to htmltools was not listed in the DESCRIPTION file of the rcdimple package. Forked the package from https://github.com/timelyportfolio/rcdimple and added the dependencies to the DESCRIPTION file (https://github.com/kilimba/rcdimple). Can now deploy a shiny app which uses the rcdimple package to shinayapps.io. Have made a Pull Request to master branch