Hello again,
I have put this together (see below code). It doesn't give exactly the same error, but does give an error when doing the same action (changing the 'Report group' control). I think it is the same reason that the error is occurring (something to do with order of operations).
It's not very minimal, I'm afraid, but I have tried to cut some stuff out to make it shorter.
Thanks for taking the time to look at this for me. I am learning quite a lot of new things via this forum!
Will
#Load packages
#=============
pkgs <- c('shiny', 'ggplot2', 'data.table')
lapply(pkgs, library, character.only = TRUE)
#Load data
#=========
sYN <- function(x){sample(c('Y','N'), x, replace=T)}
dat <- data.table(District=rep('District A',200), School=c(rep('School A',100),rep('School B',100)),
Sex=rep(c('girl','boy'),100),YearGroup=rep(paste('yr',1:5),40),Q1=sYN(200),Q2=sYN(200),
Q3=sYN(200),Q4=sYN(200),Q5=sYN(200),Q6=sYN(200),Q7=sYN(200),Q8=sYN(200),Q9=sYN(200),
Q10=sYN(200),Q11=sYN(200),Q12=sYN(200),Q13=sYN(200),Q14=sYN(200),Q15=sYN(200),Q16=sYN(200),
Q17=sYN(200),Q18=sYN(200))
dat <- dat[,All:='All'] #add All column for use in not analysing by a 'by' variable
grdropdown <- data.table(group=c(rep('Demographics',3),rep('Health',3)), report=paste('Report',1:6))
qgroups <- data.table(group=c(rep('Demographics',9),rep('Health',9)),report=c(rep(paste('Report',1:3),3),
rep(paste('Report',4:6),3)), var=paste0('Q',1:18))
#Identify user
#=============
user <- 'Brian School' #Sys.getenv("SHINYPROXY_USERNAME")
role <- 'School' #Sys.getenv("SHINYPROXY_USERGROUPS")
# Define UI
#==========
ui <- fluidPage(
fluidRow(
column(10, titlePanel('Demo',windowTitle = 'Demo App')),
column(2, style = "margin-top: 50px;", actionButton('dlbutt', 'Download PDF'))
),
fluidRow(
br(),
column(4, tagList(
selectInput('group', 'Report group', choices = c('Demographics','Health')),
uiOutput('reportdd')
)
),
column(4, selectInput('by', 'Plot by', choices = c('Sex','YearGroup'))),
column(4, selectInput('comp', 'Comparator', choices = c('All', 'District')))
),
plotOutput('heatmap')
)
# Define server logic
#====================
server <- function(input, output) {
output$reportdd <- renderUI({
selectInput('report', 'Report', grdropdown[group==input$group, report])
})
qvars <- reactive({
req(input$report, input$group)
qgroups[group==input$group & report==input$report][['var']]
})
pheight <- reactive({
length(qvars())*50
})
plotdata <- reactive({
main <- 'School A'
by <- input$by
compfield <- input$comp
comp <- if(compfield=='All'){'All'} else {'District A'}
mainchoice <- 'School'
idvars <- c('All', 'School', 'District', by)
vars <- c(idvars, qvars())
a1 <- dat[, ..vars] #select the columns for this analysis
a2 <- melt(a1, id.vars=idvars, measure.vars=qvars()) #change to long format
a3 <- a2[get(mainchoice)==main,]
a4 <- a3[, .N, keyby=.(by=get(by), variable, value)] #count up values by comparators
a5 <- dcast(a4, by + variable ~ value, value.var='N', fun.aggregate = sum) #change to wide format
a6 <- a5[, .(Y, N, Sum=sum(Y,N), Percent=Y/sum(Y, N)), keyby=.(by, variable)]#calculate percentages
setnames(a6, old = 'by', new = paste0(by))
a7 <- a6[, Facet:=main]
c1 <- a2[grepl(comp, get(compfield)),] #create comparator dataset
c2 <- c1[, .N, keyby=.(by=get(by), variable, value)] #count up values by comparators
c3 <- dcast(c2, by + variable ~ value, value.var='N', fun.aggregate = sum) #change to wide format
c4 <- c3[, .(Y, N, Sum=sum(Y,N), Percent=Y/sum(Y, N)), keyby=.(by, variable)]#calculate percentages
setnames(c4, old = 'by', new = paste0(by))
c5 <- c4[, Facet:=comp]
plotdat <- rbindlist(list(a7, c5), use.names = T)
plotdat$Facet <- factor(plotdat$Facet, levels=c(main, comp))
return(na.omit(plotdat))
})
th <- theme_minimal()
observe({
output$heatmap <- renderPlot({
ggplot(plotdata(), aes(x=get(input$by), y=variable, label=paste0(round(Percent*100,1),'%'))) +
geom_tile(aes(fill = Percent), colour = "white", size=2) + th +
guides(fill='none', color='none', alpha='none') + facet_wrap(~Facet, ncol=2) +
scale_fill_gradientn(colors=c('#f03b20', '#ffeda0', '#31a354'), values=c(0,0.5,1)) +
geom_text(size=5) + labs(y=element_blank(), x=input$by)
}
, height=pheight()
)
})
}
# Create Shiny object
#====================
shinyApp(ui = ui, server = server)