Related
This is the next step in my attempt to build a user-friendly transition matrix in R, a follow-on to post How to add a vertical line to the first column header in a data table?. I have been spoiled by the ease of drafting eye-friendly tables in Excel and have been struggling with this in R Shiny.
Running the MWE code at the bottom generates the transition table shown on the left side of the image below (with my comments overlaying). Expressing my question in Excel-speak, I'm trying to merge the top 2 cells (rows) in the left-most column (call them cells A1 and A2), eliminate the small bit of line just above "to_state" (cell A2)(item #1 in the image), eliminate that first column's header "to_state" (in cell A2)(item #2 in the image), and into that merged column header space insert an object similar to the object hovering over the "From" columns to the right, that states "To state where end period = x", where x is the value of object transTo() (item #3 in the image). Any suggestions for doing this? Using DT for the table rendering if possible.
I'm open to any other suggestion for drafting a user-friendly, understandable state transition matrix that delineates to/from columns/rows and reactively shows the to/from periods.
Post Shiny: Merge cells in DT::datatable seems promising but it addresses merging rows in the body of the table and not header rows.
Please note that in the fuller code, the table dynamically contracts/expands based on the number of unique states detected in the underlying data. States can range from 2 to 12.
MWE code:
library(DT)
library(shiny)
library(dplyr)
library(htmltools)
library(data.table)
data <-
data.frame(
ID = c(1,1,1,2,2,2,3,3,3),
Period = c(1, 2, 3, 1, 2, 3, 1, 2, 3),
Values = c(5, 10, 15, 0, 2, 4, 3, 6, 9),
State = c("X0","X1","X2","X0","X2","X0", "X2","X1","X0")
)
numTransit <- function(x, from=1, to=3){
setDT(x)
unique_state <- unique(x$State)
all_states <- setDT(expand.grid(list(from_state = unique_state, to_state = unique_state)))
dcast(x[, .(from_state = State[from],
to_state = State[to]),
by = ID]
[,.N, c("from_state", "to_state")]
[all_states,on = c("from_state", "to_state")],
to_state ~ from_state, value.var = "N"
)
}
ui <- fluidPage(
tags$head(tags$style(".datatables .display {margin-left: 0;}")), # < left-align the table
h4(strong("Base data frame:")),
tableOutput("data"),
h4(strong("Transition table inputs:")),
numericInput("transFrom", "From period:", 1, min = 1, max = 3),
numericInput("transTo", "To period:", 2, min = 1, max = 3),
h4(strong("Output transition table:")),
DTOutput("resultsDT"),
)
server <- function(input, output, session) {
results <-
reactive({
results <- numTransit(data, input$transFrom, input$transTo) %>%
replace(is.na(.), 0) %>%
bind_rows(summarise_all(., ~(if(is.numeric(.)) sum(.) else "Sum")))
results <- cbind(results, Sum = rowSums(results[,-1]))
})
output$data <- renderTable(data)
output$resultsDT <- renderDT(server=FALSE, {
req(results())
datatable(
data = results(),
rownames = FALSE,
filter = 'none',
container = tags$table(
class = 'display',
tags$thead(
tags$tr(
tags$th(colspan = 1, '', style = "border-right: solid 1px;"),
tags$th(colspan = 10, sprintf('From state where initial period = %s', input$transFrom))
),
tags$tr(
mapply(tags$th, colnames(results()), style = sprintf("border-right: solid %spx;", c(1L, rep(0, ncol(results())-1L))), SIMPLIFY = FALSE)
)
)
),
options = list(scrollX = F
, dom = 'ft'
, lengthChange = T
, pagingType = "numbers" # hides Next and Previous buttons
, autoWidth = T
, info = FALSE # hide the "Showing 1 of 2..." at bottom of table
, searching = FALSE # removes search box
),
class = "display"
) %>%
formatStyle(c(1), `border-right` = "solid 1px")
})
}
shinyApp(ui, server)
Please reference these related posts that lead to the solution shown at the bottom. The posts that built up to this solution are How to merge to row cells in data table?, How to add a vertical line to the first column header in a data table?, and How to add reactive object to secondary column header in output table?
Solution:
library(DT)
library(shiny)
library(dplyr)
library(htmltools)
library(data.table)
data <-
data.frame(
ID = c(1,1,1,2,2,2,3,3,3),
Period = c(1, 2, 3, 1, 2, 3, 1, 2, 3),
Values = c(5, 10, 15, 0, 2, 4, 3, 6, 9),
State = c("X0","X1","X2","X0","X2","X0", "X2","X1","X0")
)
numTransit <- function(x, from=1, to=3){
setDT(x)
unique_state <- unique(x$State)
all_states <- setDT(expand.grid(list(from_state = unique_state, to_state = unique_state)))
dcast(x[, .(from_state = State[from],
to_state = State[to]),
by = ID]
[,.N, c("from_state", "to_state")]
[all_states,on = c("from_state", "to_state")],
to_state ~ from_state, value.var = "N"
)
}
ui <- fluidPage(
tags$head(tags$style(".datatables .display {margin-left: 0;}")), # < left-align the table
h4(strong("Base data frame:")),
tableOutput("data"),
h4(strong("Transition table inputs:")),
numericInput("transFrom", "From period:", 1, min = 1, max = 3),
numericInput("transTo", "To period:", 2, min = 1, max = 3),
h4(strong("Output transition table:")),
DTOutput("resultsDT"),
)
server <- function(input, output, session) {
results <-
reactive({
results <- numTransit(data, input$transFrom, input$transTo) %>%
replace(is.na(.), 0) %>%
bind_rows(summarise_all(., ~(if(is.numeric(.)) sum(.) else "Sum")))
results <- cbind(results, Sum = rowSums(results[,-1]))
})
output$data <- renderTable(data)
output$resultsDT <- renderDT(server=FALSE, {
req(results())
datatable(
data = results(),
rownames = FALSE,
filter = 'none',
container = tags$table(
class = 'display',
tags$thead(
tags$tr(
tags$th(rowspan = 2, sprintf('To state where end period = %s', input$transTo), style = "border-right: solid 1px;"),
tags$th(colspan = 10, sprintf('From state where initial period = %s', input$transFrom))
),
tags$tr(
mapply(tags$th, colnames(results())[-1], style = sprintf("border-right: solid %spx;", rep(0, ncol(results()) - 1L)), SIMPLIFY = FALSE)
)
)
),
options = list(scrollX = F
, dom = 'ft'
, lengthChange = T
, pagingType = "numbers" # hides Next and Previous buttons
, autoWidth = T
, info = FALSE # hide the "Showing 1 of 2..." at bottom of table
, searching = FALSE # removes search box
),
class = "display"
) %>%
formatStyle(c(1), `border-right` = "solid 1px")
})
}
shinyApp(ui, server)
I would like to add a vertical line to a DT table column header. There is guidance for adding this line in post How can I add a vertical line to a datatable?, but it applies to a static table where columns are manually set whereas in my MWE code (at bottom), the columns are set using the lapply() function in a reactive setting. So I'm having trouble using this guidance in my particular circumstances.
Any suggestions for adding a vertical line to the right of the left-most column header labeled "to_state"? As shown in this image which shows a portion of the output window when running the MWE code:
Please note that in the fuller code this MWE derives from, the table expands/contracts dynamically depending on the number of unique states detected in the underlying data. Therefore I can't use a static table set up like in the referenced related post above.
Once this is resolved, I'll have several additional questions as I struggle to make a transition table readily understandable for users (such as change the "to_state" left-most column header to "To end Period = [xxx]", but that will be addressed in another post). I'm tackling this formatting issue incrementally in baby steps.
I am very unfamiliar with HTML, CSS.
Here is the MWE code:
library(DT)
library(shiny)
library(htmltools)
library(data.table)
data <-
data.frame(
ID = c(1,1,1,2,2,2,3,3,3),
Period = c(1, 2, 3, 1, 2, 3, 1, 2, 3),
Values = c(5, 10, 15, 0, 2, 4, 3, 6, 9),
State = c("X0","X1","X2","X0","X2","X0", "X2","X1","X0")
)
numTransit <- function(x, from=1, to=3){
setDT(x)
unique_state <- unique(x$State)
all_states <- setDT(expand.grid(list(from_state = unique_state, to_state = unique_state)))
dcast(x[, .(from_state = State[from],
to_state = State[to]),
by = ID]
[,.N, c("from_state", "to_state")]
[all_states,on = c("from_state", "to_state")],
to_state ~ from_state, value.var = "N"
)
}
ui <- fluidPage(
tags$head(tags$style(".datatables .display {margin-left: 0;}")), # < left-align the table
h4(strong("Base data frame:")),
tableOutput("data"),
h4(strong("Transition table inputs:")),
numericInput("transFrom", "From Period:", 1, min = 1, max = 3),
numericInput("transTo", "To Period:", 2, min = 1, max = 3),
h4(strong("Output transition table:")),
DTOutput("resultsDT"),
)
server <- function(input, output, session) {
results <-
reactive({
results <- numTransit(data, input$transFrom, input$transTo) %>%
replace(is.na(.), 0) %>%
bind_rows(summarise_all(., ~(if(is.numeric(.)) sum(.) else "Sum")))
results <- cbind(results, Sum = rowSums(results[,-1]))
})
output$data <- renderTable(data)
output$resultsDT <- renderDT(server=FALSE, {
req(results())
datatable(
data = results(),
rownames = FALSE,
filter = 'none',
container = tags$table(
class = 'display',
tags$thead(
tags$tr(
tags$th(colspan = 1, '', style = "border-right: solid 1px;"),
tags$th(colspan = 10, sprintf('From initial Period = %s', input$transFrom))
),
tags$tr(
lapply(colnames(results()),
tags$th
)
),
)
),
options = list(scrollX = F
, dom = 'ft'
, lengthChange = T
, pagingType = "numbers" # hides Next and Previous buttons
, autoWidth = T
, info = FALSE # hide the "Showing 1 of 2..." at bottom of table
, searching = FALSE # removes search box
),
class = "display"
) %>%
formatStyle(c(1), `border-right` = "solid 1px")
})
}
shinyApp(ui, server)
We can use mapply instead of lapply to control the style parameter:
library(DT)
library(shiny)
library(dplyr)
library(htmltools)
library(data.table)
data <-
data.frame(
ID = c(1,1,1,2,2,2,3,3,3),
Period = c(1, 2, 3, 1, 2, 3, 1, 2, 3),
Values = c(5, 10, 15, 0, 2, 4, 3, 6, 9),
State = c("X0","X1","X2","X0","X2","X0", "X2","X1","X0")
)
numTransit <- function(x, from=1, to=3){
setDT(x)
unique_state <- unique(x$State)
all_states <- setDT(expand.grid(list(from_state = unique_state, to_state = unique_state)))
dcast(x[, .(from_state = State[from],
to_state = State[to]),
by = ID]
[,.N, c("from_state", "to_state")]
[all_states,on = c("from_state", "to_state")],
to_state ~ from_state, value.var = "N"
)
}
ui <- fluidPage(
tags$head(tags$style(".datatables .display {margin-left: 0;}")), # < left-align the table
h4(strong("Base data frame:")),
tableOutput("data"),
h4(strong("Transition table inputs:")),
numericInput("transFrom", "From Period:", 1, min = 1, max = 3),
numericInput("transTo", "To Period:", 2, min = 1, max = 3),
h4(strong("Output transition table:")),
DTOutput("resultsDT"),
)
server <- function(input, output, session) {
results <-
reactive({
results <- numTransit(data, input$transFrom, input$transTo) %>%
replace(is.na(.), 0) %>%
bind_rows(summarise_all(., ~(if(is.numeric(.)) sum(.) else "Sum")))
results <- cbind(results, Sum = rowSums(results[,-1]))
})
output$data <- renderTable(data)
output$resultsDT <- renderDT(server=FALSE, {
req(results())
datatable(
data = results(),
rownames = FALSE,
filter = 'none',
container = tags$table(
class = 'display',
tags$thead(
tags$tr(
tags$th(colspan = 1, '', style = "border-right: solid 1px;"),
tags$th(colspan = 10, sprintf('From initial Period = %s', input$transFrom))
),
tags$tr(
mapply(tags$th, colnames(results()), style = sprintf("border-right: solid %spx;", c(1L, rep(0, ncol(results())-1L))), SIMPLIFY = FALSE)
)
)
),
options = list(scrollX = F
, dom = 'ft'
, lengthChange = T
, pagingType = "numbers" # hides Next and Previous buttons
, autoWidth = T
, info = FALSE # hide the "Showing 1 of 2..." at bottom of table
, searching = FALSE # removes search box
),
class = "display"
) %>%
formatStyle(c(1), `border-right` = "solid 1px")
})
}
shinyApp(ui, server)
I'm working in Rbookdown and I want to place a plot and a table in one figure, how can I achieve that? Below is the code i used so far. Can you help?
```{r echo=FALSE, message=FALSE, warning=FALSE, fig.height = 3.5, out.width = '70%', fig.align = "center"}
library(knitr)
library(kableExtra)
library(tidyverse)
library(latex2exp)
options(scipen=999)
mu = 0
sigma = 1
x = 1
# draw normal distribution
range = seq(mu - 4*sigma, mu + 4*sigma, 0.01)
y = dnorm(range, mu, sigma)
plot(range, y,
main = "Standard Normal Distribution", xlab = "Z-score", ylab = " ",
type = 'l', ylim = c(0, max(y) + 0.01), axes = FALSE)
axis(1, at = seq(mu - 4*sigma, mu + 4*sigma, sigma))
# Add area to the left of x
cord.a = c(0, seq(min(range), x, 0.01))
cord.b = c(dnorm(seq(min(range), x, 0.01), mu, sigma), 0)
polygon(cord.a, cord.b, col = "#61a5ff")
text(x = 1.1, y = -.06, TeX('$z = 1.00$'), cex = .8, xpd=NA)
text(x = 0, y = .15, TeX('$p = .8413$'), cex = .8, xpd=NA)
# Create standard normal table
options(digits = 4)
u=seq(0,3.09,by=0.01)
p=pnorm(u)
m=matrix(p,ncol=10,byrow=TRUE)
df.m = as.data.frame(m)
z.values = c("**0.0**", "**0.1**", "**0.2**", "**0.3**", "**0.4**", "**0.5**", "**0.6**",
"**0.7**", "**0.8**", "**0.9**", "**1.0**", "**1.1**", "**1.2**", "**1.3**",
"**1.4**", "**1.5**", "**1.6**", "**1.7**", "**1.8**", "**1.9**","**2.0**",
"**2.1**", "**2.2**", "**2.3**", "**2.4**", "**2.5**", "**2.6**", "**2.7**",
"**2.8**", "**2.9**", "**3.0**")
df.z.values = as.data.frame(z.values)
new.m = df.z.values %>%
bind_cols(df.m)
kable(new.m,
booktabs = TRUE,
col.names = c("$Z$", "0.00","0.01", "0.02", "0.03", "0.04",
"0.05", "0.06", "0.07", "0.08", "0.09"),
escape = FALSE,
caption = "Standaard Normaalverdeling",
linesep = "",
align = c('r')) %>%
kable_styling(font_size = 10)
Try this solution:
```{r echo=FALSE, message=FALSE, warning=FALSE, include = FALSE}
library(kableExtra)
#make and save our table into working directory
table1 <- head(mtcars[1:5]) %>%
kbl() %>%
kable_styling(full_width = F) %>%
save_kable("tab_kbl.png")
#make and save our plot into working directory
png('norm_pl.png')
plot(rnorm(10))
dev.off()
```
```{r,echo=FALSE, message=FALSE, warning=FALSE, fig.cap="My image", fig.align = "center"}
library(cowplot)
#combine our images in the one
img1 <- ggdraw() + draw_image("norm_pl.png", scale = 1)
img2 <- ggdraw() + draw_image("tab_kbl.png", scale = 1)
plot_grid(img1, img2)
```
An another variant
```{r, fig.align='center', fig.cap="My beautiful image"}
library(gridExtra)
library(grid)
library(cowplot)
t1 <- tableGrob(head(mtcars[1:5]), theme = ttheme_minimal())
p2 <- ggplot(mtcars, aes(cyl, mpg)) +
geom_point()
plot_grid(t1, p2, ncol = 2, rel_widths = c(2,1))
```
I found this code online at http://www.sthda.com/english/wiki/ggplot2-quick-correlation-matrix-heatmap-r-software-and-data-visualization
It provides instructions for how to create a correlation matrix heat map and it works well. However, I was wondering how to get little stars * next to the values in the matrix that are significant. How would I go about doing that. Any help is greatly appreciated!!
mydata <- mtcars[, c(1,3,4,5,6,7)]
head(mydata)
cormat <- round(cor(mydata),2)
head(cormat)
library(reshape2)
melted_cormat <- melt(cormat)
head(melted_cormat)
library(ggplot2)
ggplot(data = melted_cormat, aes(x=Var1, y=Var2, fill=value)) +
geom_tile()
# Get lower triangle of the correlation matrix
get_lower_tri<-function(cormat){
cormat[upper.tri(cormat)] <- NA
return(cormat)
}
# Get upper triangle of the correlation matrix
get_upper_tri <- function(cormat){
cormat[lower.tri(cormat)]<- NA
return(cormat)
}
upper_tri <- get_upper_tri(cormat)
# Melt the correlation matrix
library(reshape2)
melted_cormat <- melt(upper_tri, na.rm = TRUE)
# Heatmap
library(ggplot2)
ggplot(data = melted_cormat, aes(Var2, Var1, fill = value))+
geom_tile(color = "white")+
scale_fill_gradient2(low = "blue", high = "red", mid = "white",
midpoint = 0, limit = c(-1,1), space = "Lab",
name="Pearson\nCorrelation") +
theme_minimal()+
theme(axis.text.x = element_text(angle = 45, vjust = 1,
size = 12, hjust = 1))+
coord_fixed()
reorder_cormat <- function(cormat){
# Use correlation between variables as distance
dd <- as.dist((1-cormat)/2)
hc <- hclust(dd)
cormat <-cormat[hc$order, hc$order]
}
# Reorder the correlation matrix
cormat <- reorder_cormat(cormat)
upper_tri <- get_upper_tri(cormat)
# Melt the correlation matrix
melted_cormat <- melt(upper_tri, na.rm = TRUE)
# Create a ggheatmap
ggheatmap <- ggplot(melted_cormat, aes(Var2, Var1, fill = value))+
geom_tile(color = "white")+
scale_fill_gradient2(low = "blue", high = "red", mid = "white",
midpoint = 0, limit = c(-1,1), space = "Lab",
name="Pearson\nCorrelation") +
theme_minimal()+ # minimal theme
theme(axis.text.x = element_text(angle = 45, vjust = 1,
size = 12, hjust = 1))+
coord_fixed()
# Print the heatmap
print(ggheatmap)
ggheatmap +
geom_text(aes(Var2, Var1, label = value), color = "black", size = 4) +
theme(
axis.title.x = element_blank(),
axis.title.y = element_blank(),
panel.grid.major = element_blank(),
panel.border = element_blank(),
panel.background = element_blank(),
axis.ticks = element_blank(),
legend.justification = c(1, 0),
legend.position = c(0.6, 0.7),
legend.direction = "horizontal")+
guides(fill = guide_colorbar(barwidth = 7, barheight = 1,
title.position = "top", title.hjust = 0.5))
cor() doesn't show the significance level, you may have to use rcorr() from Hmisc package
This is quite similar to what you want (the graphic output is not so nice though)
library(ggplot2)
library(reshape2)
library(Hmisc)
library(stats)
abbreviateSTR <- function(value, prefix){ # format string more concisely
lst = c()
for (item in value) {
if (is.nan(item) || is.na(item)) { # if item is NaN return empty string
lst <- c(lst, '')
next
}
item <- round(item, 2) # round to two digits
if (item == 0) { # if rounding results in 0 clarify
item = '<.01'
}
item <- as.character(item)
item <- sub("(^[0])+", "", item) # remove leading 0: 0.05 -> .05
item <- sub("(^-[0])+", "-", item) # remove leading -0: -0.05 -> -.05
lst <- c(lst, paste(prefix, item, sep = ""))
}
return(lst)
}
d <- mtcars
cormatrix = rcorr(as.matrix(d), type='spearman')
cordata = melt(cormatrix$r)
cordata$labelr = abbreviateSTR(melt(cormatrix$r)$value, 'r')
cordata$labelP = abbreviateSTR(melt(cormatrix$P)$value, 'P')
cordata$label = paste(cordata$labelr, "\n",
cordata$labelP, sep = "")
cordata$strike = ""
cordata$strike[cormatrix$P > 0.05] = "X"
txtsize <- par('din')[2] / 2
ggplot(cordata, aes(x=Var1, y=Var2, fill=value)) + geom_tile() +
theme(axis.text.x = element_text(angle=90, hjust=TRUE)) +
xlab("") + ylab("") +
geom_text(label=cordata$label, size=txtsize) +
geom_text(label=cordata$strike, size=txtsize * 4, color="red", alpha=0.4)
Source
difference_p is the P_value of correlation matrix,
ax5 draws the sns.heatmap and return as ax5
data=correlation_p
for y in range(data.shape[0]):
for x in range(data.shape[1]):
if data[y,x]<0.1:
ax4.text(x + 0.5, y + 0.5, '-',size=48,
horizontalalignment='center',
verticalalignment='center',
)
I'm developping a Shiny app to filter a database (like Excel), and I'd like to stop all the calculation of the app when a Drop Down Button is open. Do you know how could I do that please ? It's my first Shiny app, so I'm pretty sure that I made some silly mistakes.
In my Drop Down Button, I have a CheckBoxGroupInput, with the different choices for one variable of my database. Problem : I have to wait a few seconds between each selection inside the CheckBoxGroupInput, because the app is refreshing for each additionnal choice in the CheckBox.
An example for one variable :
ui :
dropdownButton(
label = "Country :", status = "default", width = 200, circle = FALSE,
actionButton(inputId = "country_all", label = "(Un)select all"),
uiOutput("countrybis")
),
verbatimTextOutput(outputId = "country_print")
server :
Function for refreshing each list in the different CheckBox :
Function_List_Data <- function(p_type, p_processchoice, p_year, p_variable, p_product, p_country,
p_item, p_season, p_region, p_calcamp){
if(p_processchoice == "GROSSVAR"){
data <- dataset_var[YEARBIS >= p_year[1] & YEARBIS <= p_year[2],]}
else if(p_processchoice == "YIELD"){
data <- dataset_rdt[YEARBIS >= p_year[1] & YEARBIS <= p_year[2],]}
else{data <- dataset[YEARBIS >= p_year[1] & YEARBIS <= p_year[2],]}
if (p_region == 2) {data <- data[REGION %in% list("EU-15","EU-27","EU-28")]}
else if (p_region == 3) {data <- data[REGION %in% list("C.I.S.")]}
if (p_calcamp == 2) {data <- data[`CAMPAIGN/CALENDAR` == "CAMPAIGN",]}
else if (p_calcamp == 3) {data <- data[`CAMPAIGN/CALENDAR` == "CALENDAR",]}
else if (p_calcamp == 4) {data <- data[`CAMPAIGN/CALENDAR` == "OTHERS",]}
if (!is.null(p_variable)) {data <- data[VARIABLE %in% p_variable]}
if (!is.null(p_product)) {data <- data[PRODUCT %in% p_product,]}
if (!is.null(p_country)) {data <- data[COUNTRY %in% p_country,]}
if (!is.null(p_item)) {data <- data[ITEM %in% p_item,]}
if (!is.null(p_season)) {data <- data[SEASON %in% p_season,]}
if(nrow(data)<1){ data <- data[1,] }
if (p_type == "VARIABLE"){List <- unique(unlist(data$VARIABLE), use.names = FALSE)}
else if (p_type == "PRODUCT"){List <- unique(unlist(data$PRODUCT), use.names = FALSE)}
else if (p_type == "COUNTRY"){List <- unique(unlist(data$COUNTRY), use.names = FALSE)}
else if (p_type == "ITEM"){List <- unique(unlist(data$ITEM), use.names = FALSE)}
else if (p_type == "SEASON"){List <- unique(unlist(data$SEASON), use.names = FALSE)}
return(List)
}
Calculation for the Country column :
Country_List <- reactive({
Function_List_Data(p_type = "COUNTRY",
p_processchoice = input$dataprocess_choice,
p_year = input$year,
p_variable = input$variable_list,
p_product = input$product_list,
p_country = NULL,
p_item = input$item_list,
p_season = input$season_list,
p_region = input$region,
p_calcamp = input$campaign_calendar)})
observeEvent(input$country_all, {
if (is.null(input$country_list)) {
updateCheckboxGroupInput(session = session, inputId = "country_list", selected = Country_List())}
else {updateCheckboxGroupInput(session = session, inputId = "country_list", selected = "")}
})
output$country_print <- renderPrint({
if(is.null(input$country_list)){"- ALL -"}
else{as.matrix(input$country_list)}
})
output$countrybis <- renderUI({
checkboxGroupInput(inputId = "country_list", label = "Choose", choices = sort(Country_List()), selected = input$country_list)
})
EDIT :
When I calculate the Country_List only when I click on the DropdownButton, it's not working, you can see the error on the screen :
Error received : the Country_List is calculate after the CheckBox is print
.
Button Select All / Unselect All :
observeEvent(input$country_all, {
Country_List <- Function_List_Data(p_type = "COUNTRY",
p_processchoice = input$dataprocess_choice,
p_year = input$year,
p_variable = input$variable_list,
p_product = input$product_list,
p_country = NULL,
p_item = input$item_list,
p_season = input$season_list,
p_region = input$region,
p_calcamp = input$campaign_calendar)
if (is.null(input$country_list)) {
updateCheckboxGroupInput(session = session, inputId = "country_list", selected = Country_List)}
else {updateCheckboxGroupInput(session = session, inputId = "country_list", selected = "")}})
RenderPrint :
output$country_print <- renderPrint({
if(is.null(input$country_list)){"- ALL -"}
else{as.matrix(input$country_list)}})
CheckBox :
output$countrybis <- renderUI({
observeEvent(input$Country_DropDown,{
print("bla")
Country_List <- Function_List_Data(p_type = "COUNTRY",
p_processchoice = input$dataprocess_choice,
p_year = input$year,
p_variable = input$variable_list,
p_product = input$product_list,
p_country = NULL,
p_item = input$item_list,
p_season = input$season_list,
p_region = input$region,
p_calcamp = input$campaign_calendar)
})
checkboxGroupInput(inputId = "country_list", label = "Choose", choices = sort(Country_List), selected = input$country_list) })