Exponential Smoothing in R and representing with Shiny - r

I want to build forecast techniques that exponential smoothing method is one of my selection. However, I have some issues with representing the ggplot and the result/report of the calculation.
Initially, I am generating random dataset in order to be used for this technique where alpha and number of periods to be forecasted are determined by the user. For instance; i have 100 days and next 4 days are willing to be estimated with their lines -fit, upper and lower-. Then I want to learn the values of this data as a table.
When I try to visualize the plot, the error is: ggplot2 doesn't know how to deal with data of class mtstsmatrix
Secondly, I would like to monitor the data like:
require(shiny)
require(ggplot2)
require(forecast)
require(TTR)
shinyServer(function(input, output, session){
set.seed(123)
output$es1 <- renderPlot({
tmp <- data.frame(time = 1:100, sales = round(runif(100, 150, 879)) )
tmp.mean <- HoltWinters(x=tmp$sales, alpha = input$alpha, beta = FALSE,gamma=FALSE)
tmp.pred <- predict(tmp.mean,n.ahead = input$h, prediction.interval = TRUE)
y <- ggplot(tmp, aes(time, sales)) +
geom_line() +
geom_line(data=tmp.pred, aes(y=tmp.pred[,1]),color="red") +
geom_line(data=tmp.pred, aes(y=tmp.pred[,2]),color="blue") +
xlab("Days") +
ylab("Sales Quantity")+
ggtitle(title)
y })
output$infoes <- renderDataTable({
tmp <- data.frame(time = 1:100, sales = round(runif(100, 150, 879)) )
tmp.mean <- HoltWinters(x=tmp$sales, alpha = input$alpha, beta = FALSE,gamma=FALSE)
tmp.pred <- predict(tmp.mean,n.ahead = input$h, prediction.interval = TRUE)
tmp.pred
})
ui
require(shiny)
require(ggplot2)
require(forecast)
require(TTR)
shinyUI(pageWithSidebar(
headerPanel("Forecasting Methods"),
sidebarPanel(
h3(strong("Exponential Smoothing",style = "color:black")),
br(),
sliderInput("h","Number of periods for forecasting:",
min = 1, max = 20, step= 1, value = 4),
sliderInput("alpha","Alpha (Smoothing Parameter):",
min = 0.05, max = 1, step= 0.05, value = 0.01)
),
mainPanel(
tabsetPanel( id="tabs",
tabPanel("Exponential Smoothing",
value="panel",
plotOutput(outputId = "es1",
width = "900px",height = "400px"),
dataTableOutput(outputId="infoes"))
))))

You had a to make tmp.pred palatable for ggplot as was said in the comments. You also don't have to create the same data in multiple statements, a reactive command is good for that:
ui.R (unchanged)
require(shiny)
require(ggplot2)
require(forecast)
require(TTR)
shinyUI(pageWithSidebar(
headerPanel("Forecasting Methods"),
sidebarPanel(
h3(strong("Exponential Smoothing",style = "color:black")),
br(),
sliderInput("h","Number of periods for forecasting:",
min = 1, max = 20, step= 1, value = 4),
sliderInput("alpha","Alpha (Smoothing Parameter):",
min = 0.05, max = 1, step= 0.05, value = 0.01)
),
mainPanel(
tabsetPanel( id="tabs",
tabPanel("Exponential Smoothing",
value="panel",
plotOutput(outputId = "es1",
width = "900px",height = "400px"),
dataTableOutput(outputId="infoes"))
))))
server.R
require(shiny)
require(ggplot2)
require(forecast)
require(TTR)
shinyServer(function(input, output, session){
set.seed(123)
predset <- reactive({
tmp <- data.frame(time = 1:100, sales = round(runif(100, 150, 879)) )
tmp.mean <- HoltWinters(x=tmp$sales, alpha = input$alpha, beta = FALSE,gamma=FALSE)
tmp.pred <- data.frame(predict(tmp.mean,n.ahead = input$h, prediction.interval = TRUE), time = tmp[nrow(tmp), "time"] + 1:input$h)
list(tmp = tmp, tmp.pred = tmp.pred)
})
output$es1 <- renderPlot({
tmp <- predset()$tmp
tmp.pred <- predset()$tmp.pred
y <- ggplot(tmp, aes(time, sales)) +
geom_line() +
geom_line(data=tmp.pred, aes(y=upr),color="red") +
geom_line(data=tmp.pred, aes(y=fit),color="blue") +
geom_line(data=tmp.pred, aes(y=lwr),color="red") +
xlab("Days") +
ylab("Sales Quantity")+
ggtitle("title")
y })
output$infoes <- renderDataTable({
predset()$tmp.pred
})
})

Related

Shiny App in R: How to connect input and output

I do not know how to connect input (n) in the slider and output (plot). When I move the bottom on the slider in the shinny app, the plot did not change. I am wondering if the output and input did not link together approporatedly.
library(ggplot2)
library(shiny)
plot<-function(x,y,xlim=c(-3,3)){
x <- seq(-4, 4, by=0.01)
norm_dens <- dnorm(x)
t_dens <- dt(x, df = n-1)
df = data.frame(x = x, z = norm_dens, t = t_dens)
ggplot(data = df, aes(x)) +
geom_line(aes(y = z, colour = "z"))+
geom_line(aes(y = t,color = "t"))+
labs(x="x", y = "")+
scale_color_manual(name = "l", values = c("z" = "blue", "t" = "red"))+
coord_cartesian(xlim = xlim)
}
plot(x,y)
## UI function
ui <- fluidPage(
mainPanel(
plotOutput(outputId="plot")),
fluidRow(
column(2,
"Sample Size",
sliderInput("n", label = "n", value = 5, min = 2, max = 100),step=1)
)
)
# Server logic
server <- function(input, output) {
reactive({
df %>%
filter(n %in% input$n)
})
output$plot<-renderPlot({
plot(x,y)
})
}
## Run shiny app
shinyApp(ui, server)
You don't need the reactive here. Try this:
library(ggplot2)
library(shiny)
plot<-function(x,y,xlim=c(-3,3),n){
x <- seq(-4, 4, by=0.01)
norm_dens <- dnorm(x)
t_dens <- dt(x, df = n-1)
df = data.frame(x = x, z = norm_dens, t = t_dens)
ggplot(data = df, aes(x)) +
geom_line(aes(y = z, colour = "z"))+
geom_line(aes(y = t,color = "t"))+
labs(x="x", y = "")+
scale_color_manual(name = "l", values = c("z" = "blue", "t" = "red"))+
coord_cartesian(xlim = xlim)
}
## UI function
ui <- fluidPage(
mainPanel(
plotOutput(outputId="plot")),
fluidRow(
column(2,
"Sample Size",
sliderInput("n", label = "n", value = 5, min = 2, max = 100),step=1)
)
)
# Server logic
server <- function(input, output) {
output$plot<-renderPlot({
req(input$n)
plot(x,y,n=input$n)
})
}
## Run shiny app
shinyApp(ui, server)`enter code here`

Isolating variable in Shiny

Shiny beginner question, but getting tired after reading the docs and apparently missing the point of isolate(). I am working on a simple app for simulating phenotype based on genotypes. Not important, unless you are a geneticist. What I want to achieve is that only changing values of m or N results in re-sampling genotypes G and displays them in the table. When I change mean effect or its std. dev., I want only the 1 st row values to change. Was trying to add isolate when I call currG() and currBetas() but no desired effect achieved. Would be grateful for some hints. The code:
library(shiny)
# Define UI for application that draws a histogram
ui <- fluidPage(
# Application title
titlePanel("Phenotype simulator"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
sliderInput("N",
"Number of individuals:",
min=1000,
max=10000,
step = 1000,
value=5000),
sliderInput("m",
"Number of markers:",
min=1,
max=10,
step=1,
value=5),
sliderInput("betas_mu",
"Mean effect:",
min=0,
max=5,
step=.5,
value=1),
sliderInput("betas_sd",
"Effect SD:",
min=0,
max=3,
step=0.1,
value=1),
sliderInput("e_mu",
"Mean error:",
min=0,
max=0.5,
step=0.01,
value=0.25),
sliderInput("e_sd",
"Error SD:",
min=0,
max=1,
step=0.01,
value=1),
sliderInput("m_neg",
"Number of markers with negative effect:",
value = 0,
step = 1,
min = 0,
max = 5
),
sliderInput("q",
"Minor allele frequency:",
min=0,
max=1,
step=0.01,
value=.33),
# sliderInput("precision",
# "Decimals:",
# min=1,
# max=5,
# value=3),
sliderInput("bins",
"Number of bins:",
min = 1,
max = 50,
value = 30)
),
# Show a plot of the generated distribution
mainPanel(
p("Error and simulated trait distributions", style="font-size:15pt"),
plotOutput("distPlot"),
p("Genotypes for the first 5 individuals", style="font-size:15pt"),
tableOutput("genos"),
p("Distribution of effect sizes", style="font-size:15pt"),
plotOutput("eff_distPlot")
)
)
)
# Define server logic required to draw a histogram
server <- function(input, output) {
currG <- function() {
p <- 1 - input$q
q <- input$q
m <- input$m
N <- input$N
gt <- sample(x = c(0,1,2), size = (input$N * input$m), replace = T, prob = c(p^2, p*q, q^2))
G <- matrix(gt, ncol = m, byrow = T)
return(G)
}
currBetas <- function() {
cg <- currG()
m <- dim(cg)[2]
N <- dim(cg)[1]
m_neg <- input$m_neg
betas <- abs(rnorm(n = m, mean = input$betas_mu, sd = input$betas_sd))
negative_idx <- sample(c(1:m), size=m_neg, replace=F)
signs <- rep(1, times=m)
betas[negative_idx] <- -betas[negative_idx]
return(list(betas=betas, signs=signs))
}
currPheno <- function() {
G <- currG()
tmp <- currBetas()
N <- dim(G)[1]
m <- dim(G)[2]
m_neg <- input$m_neg
errors <- rnorm(n = N, mean = input$e_mu, sd = input$e_sd)
y <- G %*% (tmp$signs * tmp$betas) + errors
y2 <- round(y, digits = 3)
data <- data.frame(error = errors, y = y2)
dat <- data %>% pivot_longer(cols = c(error, y))
return(list(dat=dat, betas=betas, G=G))
}
output$eff_distPlot <- renderPlot({
dat <- data.frame(value=rnorm(n = 1000, mean = input$betas_mu, sd = input$betas_sd))
ggplot(dat, mapping = aes(x=value)) +
geom_histogram(mapping = aes(fill='orange')) +
theme_bw()
})
output$distPlot <- renderPlot({
new_data = currPheno()
ggplot(new_data$dat, mapping = aes(x=value)) +
geom_histogram(mapping = aes(fill=name), bins = input$bins) +
theme_bw() +
facet_wrap(~name)
})
output$genos <- renderTable({
G <- currG()
B <- currBetas()
G <- G[1:5,]
tmp <- apply(G, MARGIN = c(1,2), as.integer)
tmp <- cbind(c('effect', paste0("ind", 1:dim(G)[1])), rbind(round(B$betas, 3), G))
colnames(tmp) <- c(" ", paste0("SNP", c(1:dim(G)[2])))
print(tmp)
},
colnames = T
)}
# Run the application
shinyApp(ui = ui, server = server)
Indeed, reactiveValues along with observeEvent and observe seem to be a much nicer and cleaner way to achieve what I wanted. Still a lot to learn when it comes to Shiny but one step forward has been made. Thanx MrFlick for suggestions!
library(shiny)
# Define UI for application that draws a histogram
ui <- fluidPage(
# Application title
titlePanel("Phenotype simulator"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
sliderInput("N",
"Number of individuals:",
min=1000,
max=10000,
step = 1000,
value=5000),
sliderInput("m",
"Number of markers:",
min=1,
max=10,
step=1,
value=5),
sliderInput("betas_mu",
"Mean effect:",
min=0,
max=5,
step=.5,
value=1),
sliderInput("betas_sd",
"Effect SD:",
min=0,
max=3,
step=0.1,
value=1),
sliderInput("e_mu",
"Mean error:",
min=0,
max=0.5,
step=0.01,
value=0.25),
sliderInput("e_sd",
"Error SD:",
min=0,
max=1,
step=0.01,
value=1),
sliderInput("m_neg",
"Number of markers with negative effect:",
value = 0,
step = 1,
min = 0,
max = 5
),
sliderInput("q",
"Minor allele frequency:",
min=0,
max=1,
step=0.01,
value=.33),
# sliderInput("precision",
# "Decimals:",
# min=1,
# max=5,
# value=3),
sliderInput("bins",
"Number of bins:",
min = 1,
max = 50,
value = 30)
),
# Show a plot of the generated distribution
mainPanel(
p("Genotypes for the first 5 individuals", style="font-size:15pt"),
tableOutput("genos"),
tableOutput("betas"),
plotOutput("errors"),
plotOutput("phenos"),
)
)
)
# Define server logic required to draw a histogram
server <- function(input, output) {
rvals <- reactiveValues(
G = NULL,
betas = NULL,
errors = c(0),
phenos = c(0),
)
observeEvent(c(input$N, input$m, input$q), {
p <- 1 - input$q
q <- input$q
gt <- sample(x = c(0,1,2),
size = (input$N * input$m),
replace = T,
prob = c(p^2, p*q, q^2))
rvals$G <- matrix(gt, ncol = input$m, byrow = T)
})
observe({
betas <- abs(rnorm(n = input$m,
mean = input$betas_mu,
sd = input$betas_sd))
negative_idx <- sample(c(1:input$m), size=input$m_neg, replace=F)
signs <- rep(1, times=input$m)
betas[negative_idx] <- -betas[negative_idx]
rvals$betas <- betas
})
observe({
N <- dim(rvals$G)[1]
m <- dim(rvals$G)[2]
errors <- rnorm(n = N, mean = input$e_mu, sd = input$e_sd)
rvals$errors <- errors
})
observe({
phenos <- round(rvals$G %*% rvals$betas + rvals$errors, digits = 3)
rvals$phenos <- phenos
})
output$genos <- renderTable({
rvals$G[1:5,]
})
output$betas <- renderTable({
t(rvals$betas)
})
output$errors <- renderPlot({
x <- data.frame(errors = rvals$errors)
ggplot(x, mapping = aes(x = errors)) +
geom_histogram() +
theme_bw()
})
output$phenos <- renderPlot({
x <- data.frame(phenos = rvals$phenos)
ggplot(x, mapping = aes(x = phenos, fill = 'orange')) +
geom_histogram() +
theme_bw()
})
}
# Run the application
shinyApp(ui = ui, server = server)

Barplot in shiny: when click the actionbutton, the second barplot always appear delay and the previous figure appears

I create a barplot shiny app.
The biggest problem I met now is when I click the acitonbutton to get a new picture ,
the barplot appear delay and when I choose another input and click actionbutton again, the last barplot will appear but instantly disappear and the second picture appear.
But the input first and second time is different. Why the first picture will appear twice?
Here is my sample code,it is normal because it's a small sample.
library(shiny)
library(dplyr)
library(tidyr)
library(ggplot2)
library(gridExtra)
mean_data <- data.frame(
Name = c(paste0("Group_", LETTERS[1:20])),
matx <- matrix(sample(1:1000, 1000, replace = T), nrow = 20)
)
names(mean_data)[-1] <- c(paste0("Gene_", 1:50))
sd_data <- data.frame(
Name = c(paste0("Group_", LETTERS[1:20])),
matx <- matrix(runif(1000, 5, 10), nrow = 20)
)
names(sd_data)[-1] <- c(paste0("Gene_", 1:50))
###
ui <- fluidPage(
pageWithSidebar(
headerPanel("123"),
sidebarPanel(
selectInput(
"selectGeneSymbol",
"123:",
choices = colnames(mean_data)[-1],
multiple =F,
width = 400,
selected = 1
),
actionButton(inputId = "plot1", label = "FPKM"),
tags$h6(tags$a(href="https://www.ncbi.nlm.nih.gov/", "link",target = "_top"))
),
mainPanel(
plotOutput("plot")
#uiOutput("all")
)
)
)
server <- function(input, output, session) {
## put sd into mean_data
plotdata <- eventReactive(input$plot1, {
df <- mean_data %>% mutate(sd = sd_data[,input$selectGeneSymbol])
})
p1 <- eventReactive(input$plot1, {
ggplot(data = plotdata(), aes(x = Name, y = .data[[input$selectGeneSymbol]], fill=Name,
ymin = .data[[input$selectGeneSymbol]] - sd, ymax = .data[[input$selectGeneSymbol]] + sd )) +
geom_bar(stat = "identity", position = position_dodge(0.9), width = 0.9) +
# geom_errorbar(aes(ymin = plotdata()[,input$selectGeneSymbol] - sddata()[,input$selectGeneSymbol], ymax = plotdata()[,input$selectGeneSymbol] + sddata()[,input$selectGeneSymbol]), width = .2, position = position_dodge(0.9)) +
geom_errorbar(width = .2, position = position_dodge(0.9)) +
theme_classic2() +
rotate_x_text(angle = 45) +
theme(legend.position = "none") +
labs(title = input$selectGeneSymbol, x = NULL, y = "123_value")
})
output$plot <- renderPlot({
p1()
})
}
# Create Shiny app ----
shinyApp(ui = ui, server = server)
My real data is huge and I don't know if it is the main reason.
Or I should change the reactive() and EventReactive() or adjust the parameters ??
My sample data here is simple. You may not meet what the problem I met in my code.
I will show you some details, just like this:
That's ok.Though it may appeare slowly.
But when I choose another gene as input,
the first "Gene_1" result will appear again and then the "Gene_2" result will appear.
I hope somebody could help me or met this problem before.
Vary thankful.
As your data is large, there is a delay in generating the plot p1(). Hence, the previous plot is shown in renderPlot. The following update will show blank until a new plot is generated whenever user selects a new gene. Perhaps this will solve your issue. I cannot verify as I don't have large dataframe.
ui <- fluidPage(
pageWithSidebar(
headerPanel("123"),
sidebarPanel(
selectInput(
"selectGeneSymbol",
"123:",
choices = colnames(mean_data)[-1],
multiple =F,
width = 400,
selected = 1
),
actionButton(inputId = "plot1", label = "FPKM"),
tags$h6(tags$a(href="https://www.ncbi.nlm.nih.gov/", "link",target = "_top"))
),
mainPanel(
plotOutput("plot")
#,verbatimTextOutput("all")
)
)
)
server <- function(input, output, session) {
rv <- reactiveVal(0)
observeEvent(input$selectGeneSymbol, {rv(0)})
## put sd into mean_data
plotdata <- eventReactive(input$plot1, {
rv(0)
df <- mean_data %>% mutate(sd = sd_data[,input$selectGeneSymbol])
})
p1 <- eventReactive(input$plot1, {
req(plotdata())
p <- ggplot(data = plotdata(), aes(x = Name, y = .data[[input$selectGeneSymbol]], fill=Name,
ymin = .data[[input$selectGeneSymbol]] - sd, ymax = .data[[input$selectGeneSymbol]] + sd )) +
geom_bar(stat = "identity", position = position_dodge(0.9), width = 0.9) +
geom_errorbar(width = .2, position = position_dodge(0.9)) +
theme_classic2() +
rotate_x_text(angle = 45) +
theme(legend.position = "none") +
labs(title = input$selectGeneSymbol, x = NULL, y = "123_value")
rv(1)
p
})
observeEvent(input$plot1, {rv(1)})
output$plot <- renderPlot({
if (rv()) {
p1()
}
})
#output$all <- renderPrint(rv())
}
# Create Shiny app ----
shinyApp(ui = ui, server = server)

Update Graph in R Shiny react

I would like to understand why the graph does not update in the RShiny App generated from the code below.
What I try to do:
Generate a sample of n_data observations from a beta-distribution with certain shape parameters.
Plot the histogram of this sample, together with its mean.
Do this e_samples times and keep the means, show an updated graph every second
Plot the histogram of the vector with e_samples means
library(shiny)
library(ggplot2)
# Design the interface
ui <- fluidPage(titlePanel("Population vs sample"),
sidebarLayout(
# Function to determine the layout
sidebarPanel(
sliderInput(
'shape1',
label = 'Population shape 1:',
min = 1,
max = 9,
value = 2 ,
step = 1
),
sliderInput(
'shape2',
label = 'Population shape 2:',
min = 1,
max = 9,
value = 2 ,
step = 1
),
textInput("n_data", label = "Sample size:",
value = '25'),
textInput("e_samples", label = "number of samples:",
value = '5'),
actionButton("RerunButton", "New sample", icon("play"))
),
mainPanel(plotOutput('Sample'))
))
# Set up the server
server <- function(input, output) {
set.seed(1234)
xvals <- seq(.001, .999, by = 0.001)
# Define reactive values
avgs <- reactiveVal(vector(mode = "list", length = 1))
vals <- reactiveVal(0)
s <- reactiveVal()
sample_plot <- reactiveVal()
# This is where I hope to generate a new graph every second.
observe({
invalidateLater(1000)
cat(paste('vals', vals(), '\n'))
cat(paste('avgs', avgs(), '\n'))
if (vals() < input$e_samples) {
s(data.frame(
d = rbeta(
n = input$n_data,
shape1 = as.numeric(input$shape1),
shape2 = as.numeric(input$shape2)
)
))
temp <- s()
vals(vals() + 1)
averages <- avgs()
averages[vals()] <- mean(temp$d)
avgs(averages)
sample_plot(
ggplot() +
geom_histogram(
data = temp,
aes(x = d),
binwidth = 0.1,
fill = 'white',
col = 'black'
) +
geom_vline(xintercept = mean(temp$d)) +
xlim(0, 1) +
xlab('observation value') +
ylab('count')
)
}
})
output$Sample <- renderPlot({
sample_plot()
})
observeEvent(input$RerunButton, {
vals(0)
})
observeEvent(input$RerunButton, {
avgs(vector(mode = "list", length = 1))
})
}
shinyApp(ui = ui, server = server)
The code above only updates the graph once. Why?
All of your reactiveValues that keep changing are triggering your observe repeatedly right away. This happens five times in succession, well before 1000 msec has elapsed. To prevent this from happening, you would need to use isolate for your reactiveValues. See if this gives the right behavior:
# Set up the server
server <- function(input, output, session) {
set.seed(1234)
xvals <- seq(.001, .999, by = 0.001)
# Define reactive values
avgs <- reactiveVal(vector(mode = "list", length = 1))
vals <- reactiveVal(0)
s <- reactiveVal()
sample_plot <- reactiveVal()
# This is where I hope to generate a new graph every second.
observe({
invalidateLater(1000, session)
#cat(paste('vals', vals(), '\n'))
#cat(paste('avgs', avgs(), '\n'))
if (isolate(vals()) < input$e_samples) {
s(data.frame(
d = rbeta(
n = input$n_data,
shape1 = as.numeric(input$shape1),
shape2 = as.numeric(input$shape2)
)
))
temp <- s()
isolate(vals(vals() + 1))
averages <- isolate(avgs())
averages[vals()] <- mean(temp$d)
avgs(averages)
}
})
sample_plot <- reactive({
ggplot() +
geom_histogram(
data = s(),
aes(x = d),
binwidth = 0.1,
fill = 'white',
col = 'black'
) +
geom_vline(xintercept = mean(s()$d)) +
xlim(0, 1) +
xlab('observation value') +
ylab('count')
})
output$Sample <- renderPlot({
sample_plot()
})
observeEvent(input$RerunButton, {
vals(0)
})
observeEvent(input$RerunButton, {
avgs(vector(mode = "list", length = 1))
})
}

Shiny App the coding difference between a reactive object and wide scoping

Example might look long but it's really simple.
My issue is around having a reactive object and the use of <<-.
I have another shiny app which works great using:
blah <- reactive({
dat <<- etcetc
)
And then successfully using dat later in dataTable and plot components. But with the below I'm failing hard.
Question: What is the difference between item1 <- reactive({etc}) and item2 <<- etc
As I understand it, you can put a reactive dataset into an object (item1) and then use it later by putting item1() in your code. The scoping rules suggest you can use item2 <<- etc and then just use item2 later in your code.
contents2 <- reactive({
datp <- data.frame(mean = c(r1, r2),
chosen = c(rep("A", length(r1)), rep("B", length(r2))))
datp
})
I know I can break up my code below into the form above (with datp and datci being their own reactive objects (say contents2 and contents3), and it works) but shouldn't the scoping <<- below work?
Example:
library(ggplot2)
ui <- navbarPage("Test",
tabPanel("Panel A",
sidebarLayout(
sidebarPanel(
sliderInput("n1", "N sample 1:",
min=2, max=30, value=3),
sliderInput("n2", "N sample 2:",
min=2, max=30, value=3),
numericInput("mean1", label = h5("Mean 1"), value = 100),
numericInput("mean2", label = h5("Mean 2"), value = 80),
numericInput("sd1", label = h5("Std Dev 1"), value = 10),
numericInput("sd2", label = h5("Std Dev 2"), value = 10),
radioButtons("cilevel", "Confidence Interval",
c("99%" = 0.99,
"95%" = 0.95,
"90%" = 0.90),
selected = 0.95)
)
,
mainPanel(
plotOutput("plot")
)
)
),
tabPanel("Panel B",
sidebarLayout(
sidebarPanel(
)
,
mainPanel(
)
)
)
)
server <- function(input, output, session) {
contents1 <- reactive({
r1 <- rnorm(input$n1, input$mean1, input$sd1)
r2 <- rnorm(input$n2, input$mean2, input$sd2)
# Note the change to << now
cimult <<- qt(as.numeric(input$cilevel)/2 + .5, length(r1))
datp <<- data.frame(mean = c(r1, r2),
chosen = c(rep("A", length(r1)), rep("B", length(r2))))
datci <<- data.frame(mean = c(mean(r1), mean(r2)),
sd = c(sd(r1), sd(r2)),
n = c(length(r1), length(r2)),
se = c(sd(r1)/sqrt(length(r1)), sd(r2)/sqrt(length(r2))),
chosen = c("A", "B"))
})
output$plot <- renderPlot({
ggplot(datci, aes(x = factor(chosen),
y = mean)) +
geom_errorbar(aes(ymin = mean - cimult * se,
ymax = mean + cimult * se,
color = factor(chosen))) +
geom_point(aes(color = factor(chosen)), alpha = 0.8) +
geom_point(data = contents1(), alpha = 0.8) +
coord_flip()
})
}
shinyApp(ui = ui, server = server)

Resources