source(file = "plotDataRRP.R")
source(file = "rrpSample.R")
source(file = "rrpAsDf.R")
source(file = "rrpSigma.R")
source(file = "sampleContRRP.R")
library(haven)
library(MASS)
shinyServer(function(input, output,session) {
### LOGO ###
# Logo on tab one
output$logo <- renderUI({
tags$img(src = "https://shklinkenberg.github.io/uva_style/images/logo_uva.png",
width = "30%")
})
#------------------------------------------------------------------------------#
### REACTIVE UI ###
# Gender reactive UI tab two
output$females <- renderUI({
sliderInput("gender", "Number of females", 0, input$N, input$N/2, step = 1)
})
output$males <- renderUI({
helpText(HTML("<strong>Number of males</strong></br> "),
input$N - input$gender)
})
# Age reactive UI tab two
output$maxAge <- renderUI({
numericInput("maxAge", "Maximum age", NA, min = (input$age + 1))
})
output$minAge <- renderUI({
numericInput("minAge", "Minimumn age", NA, 0, max = (input$age - 1))
})
# DV reactive UI tab three
output$expecDV2x3 <- renderUI({
conditionalPanel("input.design == '2x3'",
helpText(input$g1),
fluidRow(
column(4,
numericInput("DV2x3.11", input$t1, 0)
),
column(4,
numericInput("DV2x3.12", input$t2, 0)
),
column(4,
numericInput("DV2x3.13", input$t3, 0)
)
),
helpText(input$g2),
fluidRow(
column(4,
numericInput("DV2x3.21", input$t1, 0)
),
column(4,
numericInput("DV2x3.22", input$t2, 0)
),
column(4,
numericInput("DV2x3.23", input$t3, 0)
)
)
)
})
output$expecDV3x2 <- renderUI({
conditionalPanel("input.design == '3x2'",
helpText(input$g1),
fluidRow(
column(6,
numericInput("DV3x2.11", input$t1, 0)
),
column(6,
numericInput("DV3x2.12", input$t2, 0)
)
),
helpText(input$g2),
fluidRow(
column(6,
numericInput("DV3x2.21", input$t1, 0)
),
column(6,
numericInput("DV3x2.22", input$t2, 0)
)
),
helpText(input$g3),
fluidRow(
column(6,
numericInput("DV3x2.31", input$t1, 0)
),
column(6,
numericInput("DV3x2.32", input$t2, 0)
)
)
)
})
output$minDV <- renderUI({
numericInput("minDV", "Minimum", NA, max = (min(meansDV()) - 1))
})
output$maxDV <- renderUI({
numericInput("maxDV", "Maximum", NA, min = (max(meansDV()) + 1))
})
# MC reactive UI tab four
output$expecMC2x3 <- renderUI({
conditionalPanel("input.design == '2x3'",
helpText(input$g1),
fluidRow(
column(4,
numericInput("MC2x3.11", input$t1, 0)
),
column(4,
numericInput("MC2x3.12", input$t2, 0)
),
column(4,
numericInput("MC2x3.13", input$t3, 0)
)
),
helpText(input$g2),
fluidRow(
column(4,
numericInput("MC2x3.21", input$t1, 0)
),
column(4,
numericInput("MC2x3.22", input$t2, 0)
),
column(4,
numericInput("MC2x3.23", input$t3, 0)
)
)
)
})
output$expecMC3x2 <- renderUI({
conditionalPanel("input.design == '3x2'",
helpText(input$g1),
fluidRow(
column(6,
numericInput("MC3x2.11", input$t1, 0)
),
column(6,
numericInput("MC3x2.12", input$t2, 0)
)
),
helpText(input$g2),
fluidRow(
column(6,
numericInput("MC3x2.21", input$t1, 0)
),
column(6,
numericInput("MC3x2.22", input$t2, 0)
)
),
helpText(input$g3),
fluidRow(
column(6,
numericInput("MC3x2.31", input$t1, 0)
),
column(6,
numericInput("MC3x2.32", input$t2, 0)
)
)
)
})
output$minMC <- renderUI({
numericInput("minMC", "Minimum", NA, max = (min(meansMC()) - 1))
})
output$maxMC <- renderUI({
numericInput("maxMC", "Maximum", NA, min = (max(meansMC()) + 1))
})
# Cont reactive UI tab five
output$dir <- renderText({
paste("Relationship with", input$nameDV)
})
output$maxCont <- renderUI({
numericInput("maxCont", "Maximum", NA, min = (input$meanCont + 1))
})
output$minCont <- renderUI({
numericInput("minCont", "Minimum", NA, max = (input$meanCont - 1))
})
# Cat reactive UI tab five
output$pCats <- renderUI({
lapply(1:input$lvl, function(i){
fluidRow(
column(6,
textInput(paste0("nameCat.", i), paste0(i, ".", " ", "Name"),
paste0("Cat", i))
),
column(6,
numericInput(paste0("pCat.", i), "Probability",
1/input$lvl, 0, 1, .1)
)
)
})
})
#------------------------------------------------------------------------------#
### StORING VARIABLES ###
# Store expected mean values in a vector
meansDV <- reactive({
if(input$design == "2x3"){
c(input$DV2x3.11, input$DV2x3.12, input$DV2x3.13,
input$DV2x3.21, input$DV2x3.22, input$DV2x3.23)
} else {
c(input$DV3x2.11, input$DV3x2.12, input$DV3x2.21,
input$DV3x2.22, input$DV3x2.31, input$DV3x2.32)
}
})
meansMC <- reactive({
if(input$design == "2x3"){
c(input$MC2x3.11, input$MC2x3.12, input$MC2x3.13,
input$MC2x3.21, input$MC2x3.22, input$MC2x3.23)
} else {
c(input$MC3x2.11, input$MC3x2.12, input$MC3x2.21,
input$MC3x2.22, input$MC3x2.31, input$MC3x2.32)
}
})
# Store measurent moment names in a vector
columnNamesDV <- reactive({
paste(input$nameDV, c(input$t1, input$t2, input$t3), sep = ".")
})
columnNamesMC <- reactive({
paste(input$nameMC, c(input$t1, input$t2, input$t3), sep = ".")
})
# Store cat probabilities in a vector
pCat <- reactive({
sapply(1:input$lvl, function(i){
input[[paste0("pCat.", i)]]
})
})
# Store cat names in a vector
nameCat <- reactive({
sapply(1:input$lvl, function(i){
input[[paste0("nameCat.", i)]]
})
})
#------------------------------------------------------------------------------#
### DATA SIMULATION AND RESHAPING
# Simulate data (output is matrix)
simMatDV <- reactive({
set.seed(input$ID)
muDV <- meansDV()
muMC <- meansMC()
if(is.null(muDV)){
muDV <- rep(0, 6)
}
if(is.null(muMC)){
muMC <- rep(0, 6)
}
mu <- c(muDV, muMC)
mvrnorm(n = input$N,
mu = mu,
Sigma = rrpSigma(input$design, .7, as.numeric(input$dirCor))
)
})
# Reshape data in data frame with grouping variable
datDV <- reactive({
set.seed(input$ID)
rrpAsDf(dat = simMatDV()[, 1:6],
N = input$N,
min = input$minDV,
max = input$maxDV,
design = input$design,
names = columnNamesDV())
})
datMC <- reactive({
set.seed(input$ID)
rrpAsDf(dat = simMatDV()[, 7:12],
N = input$N,
min = input$minMC,
max = input$maxMC,
design = input$design,
names = columnNamesMC())
})
# Create subset of data without group variable
rawDataDV <- reactive({
subset(datDV(), select = -group)
})
# Create data frame with all variables
dat <- reactive({
req(input$gender)
set.seed(input$ID)
df <- cbind(rawDataDV(), datMC())
# Sample gender
df$gender <- sample(1:2, nrow(df), replace = T,
prob = c(input$gender/input$N, (1-input$gender/input$N)))
df$gender <- ordered(df$gender, levels = 1:2, labels = c("F", "M"))
# Sample age and replace violations of min and max with mean
df$age <- round(rnorm(nrow(df), input$age))
df$age[df$age < input$minAge | df$age > input$maxAge] <- mean(df$age)
if(input$design == "2x3"){
df$group <- ordered(df$group, levels = 1:2, labels = c(input$g1, input$g2))
} else {
df$group <- ordered(df$group, levels = 1:3, labels = c(input$g1, input$g2, input$g3))
}
# attr(df$group, "labels") <- unique(df$group)
# names(attr(df$group, "labels")) <- c(input$g1, input$g2)
# Add categorical variable if supplied
if(!is.null(input$extra) && input$extra == "cat"){
# Sample categorical variable
df$cat <- sample(1:input$lvl, nrow(df), replace = T, prob = pCat())
df$cat <- ordered(df$cat, levels = 1:input$lvl, labels = nameCat())
}
# Add continuous variable if supplied (uses function sampleContRRP)
if(!is.null(input$extra) && (input$extra == "cont" ||
identical(input$extra, c("cat", "cont")))){
df$cont <- sampleContRRP(x = rowMeans(rawDataDV()),
cor = input$corCont,
mean = input$meanCont,
min = input$minCont,
max = input$maxCont)
names(df)[names(df) == "cont"] <- input$nameCont
}
set.seed(input$ID)
df <- df[sample(nrow(df)), ]
return(df)
})
#------------------------------------------------------------------------------#
### PLOTS ###
# Create title above plot
output$plotTitleDV <- renderText({
paste(input$nameDV, "per Group over Time")
})
output$plotTitleMC <- renderText({
paste(input$nameMC, "per Group over Time")
})
# Plot data
output$plotDV <- renderPlot({
req(length(input$minDV) > 0)
validate(
if(!is.na(input$minDV)){
need(all(input$minDV < meansDV()),
"Your minimum has to be smaller than the means!")
},
if(!is.na(input$maxDV)){
need(all(input$maxDV > meansDV()),
"Your maximum has to be larger than the means!")
}
)
plotDataRRP(datDV(),
input$nameDV,
c(input$g1, input$g2, input$g3),
c(input$t1, input$t2, input$t3)
)
})
output$plotMC <- renderPlot({
req(length(input$minMC) > 0)
validate(
if(!is.na(input$minMC)){
need(all(input$minMC < meansMC()),
"Your minimum has to be smaller than the means!")
},
if(!is.na(input$maxMC)){
need(all(input$maxMC > meansMC()),
"Your maximum has to be larger than the means!")
}
)
plotDataRRP(datMC(),
input$nameMC,
c(input$g1, input$g2, input$g3),
c(input$t1, input$t2, input$t3)
)
})
#------------------------------------------------------------------------------#
### NEXT BUTTONS ###
# Create next buttons
observeEvent(input$next1, {
updateTabsetPanel(session = session, inputId = "navbar",
selected = "Descriptives")
})
observeEvent(input$next2, {
updateTabsetPanel(session = session, inputId = "navbar",
selected = "Dependent Variable")
})
observeEvent(input$next3, {
updateTabsetPanel(session = session, inputId = "navbar",
selected = "Manipulation Check")
})
observeEvent(input$next4, {
updateTabsetPanel(session = session, inputId = "navbar",
selected = "Extra Variables")
})
observeEvent(input$next5, {
updateTabsetPanel(session = session, inputId = "navbar",
selected = "Download Data")
})
#------------------------------------------------------------------------------#
### VALIDATION ###
# Validation tab one
output$idText <- renderText({
validate(
need(input$ID != 1, "Fill in your student number!")
)
})
# Validation tab two
output$descText <- renderText({
req(length(input$minAge) > 0)
validate(
need(input$age, "Provide the mean age!"),
if(!is.na(input$minAge)){
need(input$minAge < input$age,
"Your minimum has to be smaller than the mean age!")
},
if(!is.na(input$maxAge)){
need(input$maxAge > input$age,
"Your maximum has to be larger than the mean age!")
}
)
})
# Validation tab five
output$extraTextCat <- renderText({
req(input$extra == "cat")
validate(
need(!any(is.na(pCat())), "Provide a probability for each category!")
)
})
output$extraTextCont <- renderText({
req(input$extra == "cont")
req(length(input$minCont) > 0)
validate(
need(input$meanCont,
paste0("Provide the mean for ", input$nameCont, "!")),
if(!is.na(input$minCont)){
need(input$minCont < input$meanCont,
paste0("Your minimum has to be smaller than the mean ",
input$nameCont, "!"))
},
if(!is.na(input$maxCont)){
need(input$maxCont > input$meanCont,
paste0("Your maximum has to be larger than the mean ",
input$nameCont, "!"))
}
)
})
#------------------------------------------------------------------------------#
### TAB SIX ###
# Create table tab six
output$table <- renderTable({
validate(
need(input$gender, "Fill in the descriptives tab!")
)
dat()
})
# Create download buttons tab six
output$downloadData <- downloadHandler(
filename = "dataRRP.csv",
content = function(file) {
write.csv(dat(), file, row.names = F)
}
)
output$downloadDataSAV <- downloadHandler(
filename = "dataRRP.sav",
content = function(file) {
write_sav(dat(), file)
}
)
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.