How to use shiny with check boxes from an excel file - r

I am trying to make a shiny app that all it does is display different line plots based on which check boxes are selected.
My data is housed in an excel file and it has 5 tabs, each of which I would like to have a plot and a corresponding check box. I have included a picture of the data
I found the code below that creates checkboxes, but it also has a slider bar that I don't need (if I could use it, I would have it set the range of years to show in the plot)
Thanks for the help
library(ggplot2)
library(tidyverse)
df <- iris[, colnames(iris) != "Species"]
ui <- fluidPage(
titlePanel("Density Plots of Quantitative Variables"),
sidebarLayout(
sidebarPanel(
sliderInput("bw", "Slide to change bandwidth of Plot",
min = 0.1,
max = 20,
value = 3,
step = 0.1,
animate = TRUE
),
checkboxGroupInput("variableinp", "Choose variables",
choices = colnames(df), selected = colnames(df)[1]
), verbatimTextOutput("value")
),
mainPanel(plotOutput("densityplot"))
)
)
server <- function(input, output) {
# observeEvent(input$variableinp, {
# print((input$variableinp))
# })
output$densityplot <- renderPlot({
if (!is.null(input$variableinp)) {
getoutandquant <- function(x) {
q1 <- quantile(x)[[2]]
q3 <- quantile(x)[[4]]
IQR <- q3 - q1
out1 <- q3 + (1.5) * IQR
out2 <- q1 - (1.5) * IQR
# Finding the list of points which are outliers for a particular variable.
out <- x[x > out1]
out2 <- x[x < out2]
outliers <- tibble(x = c(out, out2), y = 0)
return(outliers)
}
nplot <- length(input$variableinp)
x <- input$variableinp
for (i in 1:nplot) {
outlier <- getoutandquant(df[, x[i]])
}
p1 <- ggplot(df, aes_string(input$variableinp[i])) +
stat_density(geom = "line", adjust = input$bw) +
ylab("Density\n")
p1 + geom_point(data = outlier, aes(x, y), shape = 23)
}
})
}
shinyApp(ui = ui, server = server)

We can keep everything in one single plot by pivoting the data and modifying getoutandquant function with an additional argument. The purpose of this is to be able to use color argument to differentiate each column.
df <- iris[, colnames(iris) != "Species"]
#pivot data to long format
df_long <- df %>%
pivot_longer(everything())
#add an additional argument
getoutandquant <- function(x, group_name) {
q1 <- quantile(x)[[2]]
q3 <- quantile(x)[[4]]
IQR <- q3 - q1
out1 <- q3 + (1.5) * IQR
out2 <- q1 - (1.5) * IQR
# Finding the list of points which are outliers for a particular variable.
out <- x[x > out1]
out2 <- x[x < out2]
outliers <- tibble(x = c(out, out2), y = 0, group_name)
return(outliers)
}
Finally we change the server to plot one or more columns depending the number of checkboxes selected.
server <- function(input, output) {
outliers <- reactive({
#call getoutandquant function with each of the selected cols
map_dfr(input$variableinp, ~ getoutandquant(df[, ..1], group_name = .x))
})
df_long_filt <- reactive({
filter(df_long, name %in% input$variableinp)
})
output$densityplot <- renderPlot({
req(input$variableinp)
ggplot(df_long_filt()) +
stat_density(aes(x = value, color = name),
geom = "line",
adjust = input$bw
) +
labs(y = "Density\n", color = "Column") +
#we change the dataset to plot the outliers
geom_point(
data = outliers(), aes(x = x, y = y, color = group_name),
shape = 23,
size = 5
)
})
}
The ui will remain the same.
Full app:
library(shiny)
library(tidyverse)
df <- iris[, colnames(iris) != "Species"]
#pivot data to long format
df_long <- df %>%
pivot_longer(everything())
#add an additional argument
getoutandquant <- function(x, group_name) {
q1 <- quantile(x)[[2]]
q3 <- quantile(x)[[4]]
IQR <- q3 - q1
out1 <- q3 + (1.5) * IQR
out2 <- q1 - (1.5) * IQR
# Finding the list of points which are outliers for a particular variable.
out <- x[x > out1]
out2 <- x[x < out2]
outliers <- tibble(x = c(out, out2), y = 0, group_name)
return(outliers)
}
ui <- fluidPage(
titlePanel("Density Plots of Quantitative Variables"),
sidebarLayout(
sidebarPanel(
sliderInput("bw", "Slide to change bandwidth of Plot",
min = 0.1,
max = 20,
value = 3,
step = 0.1,
animate = TRUE
),
checkboxGroupInput("variableinp", "Choose variables",
choices = colnames(df), selected = colnames(df)[1]
), verbatimTextOutput("value")
),
mainPanel(plotOutput("densityplot"))
)
)
server <- function(input, output) {
outliers <- reactive({
#call getoutandquant function with each of the selected cols
map_dfr(input$variableinp, ~ getoutandquant(df[, ..1], group_name = .x))
})
df_long_filt <- reactive({
filter(df_long, name %in% input$variableinp)
})
output$densityplot <- renderPlot({
req(input$variableinp)
ggplot(df_long_filt()) +
stat_density(aes(x = value, color = name),
geom = "line",
adjust = input$bw
) +
labs(y = "Density\n", color = "Column") +
#we change the dataset to plot the outliers
geom_point(
data = outliers(), aes(x = x, y = y, color = group_name),
shape = 23,
size = 5
)
})
}
shinyApp(ui = ui, server = server)

Related

R shiny how to partly change dataframe to plot?

The composition of my data has 4 parts, all_data <- rbind(data1,data2,data3,data4)
In shiny,I want to when I slider sliderinput 1,only data1 changed in this dataframe.
When I change slider 2,only data2 changed in this dataframe.
But when I changed every slider,all data will change ,maybe I should use observeEvent like this,but I am faild.
observeEvent(ignoreInit = TRUE,
c(input$Mean1,input$SD1), {
mean1 <- input$Mea1
sd1 <- input$SD1
n_sample <- 5
x1 <- 1:5
y1 <- rnorm(n_sample,mean1, sd1)
z1 <- rep("Distribution 1",length(x1) )
mean_1 <- rep(mean(y1),length(x1))
data1 <-data.frame(x = x1,y = y1,z = z1,my_mean =mean_1)
})
There is all my code, could you please tell me how to modify it. Thanks!
rm(list = ls())
library(shiny)
library(shinythemes)
library(ggplot2)
library(plotly)
ui_chart <- sidebarPanel(width =3,position = "right",
sliderInput("Mean1", "Mean of the distrubution1", -30, 30, value = -10),
sliderInput("Mean2", "Mean of the distrubution2", -30, 30, value = 0),
sliderInput("Mean3", "Mean of the distrubution3", -30, 30, value = 10),
sliderInput("Mean4", "Mean of the distrubution4", -30, 30, value = 20),
sliderInput("SD1", "Within group sd", 0.1, 20, value =6)
)
ui <- navbarPage("Distrubution for each group", theme = shinytheme("flatly"),
tabPanel("Distrubution simulation",
titlePanel("Within group and between group variance"),
mainPanel(width = 9
,plotlyOutput("chart2")
)
,ui_chart
)
)
server <- function(input, output) {
output$chart2 <- renderPlotly({
mean1 <- input$Mean1
mean2 <- input$Mean2
mean3 <- input$Mean3
mean4 <- input$Mean4
sd1 <- input$SD1
n_sample <- 5
x1 <- 1:5
y1 <- rnorm(n_sample,mean1, sd1)
z1 <- rep("Distribution 1",length(x1) )
mean_1 <- rep(mean(y1),length(x1))
data1 <-data.frame(x = x1,y = y1,z = z1,my_mean =mean_1 )
x2 <- 6:10
y2 <- rnorm(n_sample,mean2, sd1)
z2 <- rep("Distribution 2",length(x2) )
mean_2 <- rep(mean(y2),length(x2))
data2 <-data.frame(x = x2,y = y2,z = z2,my_mean =mean_2)
x3 <- 11:15
y3 <- rnorm(n_sample,mean3, sd1)
z3 <- rep("Distribution 3",length(x3) )
mean_3 <- rep(mean(y3),length(x3))
data3 <-data.frame(x = x3,y = y3,z = z3,my_mean =mean_3)
x4 <- 16:20
y4 <- rnorm(n_sample,mean4, sd1)
z4 <- rep("Distribution 4",length(x4) )
mean_4 <- rep(mean(y4),length(x4))
data4 <-data.frame(x = x4,y = y4,z = z4,my_mean =mean_4)
all_data <- rbind(data1,data2,data3,data4)
all_data$mean_all <- mean(all_data$y)
p2 <- ggplot(data = all_data)+
geom_point(aes(x = x ,y = y,color = z))+
geom_line(aes(x = x ,y = my_mean ,color = z))+
geom_line(aes(x = x ,y = mean_all ),color = "black")+
scale_x_continuous(breaks = c(1:20),
labels = paste0("Obs",1:20))+
ggtitle("Observed sampale data")+
theme_bw()+
labs(color = "Distribution")+
theme(plot.title = element_text(hjust = 0.5))
ggplotly(p2)
})
}
shinyApp(ui, server)
Well since you are using rnorm, you are getting new random values every-time an input changes. If you want to isolate those changes, you might want to make separate reactive data objects for each of the studies. Here's one way to do that
server <- function(input, output) {
generate_data <- function(dist, ids, n_sample, sample_mean, sample_sd) {
x <- 1:5
y <- rnorm(n_sample,sample_mean, sample_sd)
z <- rep(paste("Distribution", dist),length(x) )
mean <- rep(mean(y),length(x))
data.frame(x = ids, y = y, z = z, my_mean =mean)
}
n_sample <- 5
data1 <- reactive(generate_data("1", 1:5, n_sample, input$Mean1, input$SD1))
data2 <- reactive(generate_data("2", 6:10, n_sample, input$Mean2, input$SD1))
data3 <- reactive(generate_data("3", 11:15, n_sample, input$Mean3, input$SD1))
data4 <- reactive(generate_data("4", 16:20, n_sample, input$Mean4, input$SD1))
output$chart2 <- renderPlotly({
all_data <- rbind(data1(),data2(),data3(),data4())
all_data$mean_all <- mean(all_data$y)
p2 <- ggplot(data = all_data)+
geom_point(aes(x = x ,y = y,color = z))+
geom_line(aes(x = x ,y = my_mean ,color = z))+
geom_line(aes(x = x ,y = mean_all ),color = "black")+
scale_x_continuous(breaks = c(1:20),
labels = paste0("Obs",1:20))+
ggtitle("Observed sampale data")+
theme_bw()+
labs(color = "Distribution")+
theme(plot.title = element_text(hjust = 0.5))
ggplotly(p2)
})
}
Here we make a helper function to generate the data for each of the groups. We store the data in a reactive object that only depends on the group mean. Therefore they won't change when other inputs change

DNBuilder Shinyapps: change term labels

Im building a shinyapp from a log regression using the DynNom::DNbuilder R package. I obtained the ui.R, server.R and global.R code and the app works. However, I'm trying to change the format of the sliders and the labels but I haven't been able to do so.
I'd appreciate if someone could shed some light here . Thanks!
Here's my model and the labels i would like the app to show:
data <- data.frame(
x = c(0,1,0),
y = c(3,6,2),
z = c(1.3, 2.8, 3.1),
w = c(1,0,0)
)
model <- lrm(x ~ y + z + w, data = data)
modellabels <- c("ylabel", "zlabel", "wlabel")
Here's the DNbuilder code:
model <- lrm(x ~ y + z + w, data =data
DNbuilder(model, data = data, clevel = 0.95, m.summary = c("raw"), covariate = c("numeric"))
Here's what I got after running DNbuilder:
**ui.R**
ui = bootstrapPage(fluidPage(
titlePanel('app'),
sidebarLayout(sidebarPanel(uiOutput('manySliders'),
uiOutput('setlimits'),
actionButton('add', 'Predict'),
br(), br(),
helpText('Press Quit to exit the application'),
actionButton('quit', 'Quit')
),
mainPanel(tabsetPanel(id = 'tabs',
tabPanel('Graphical Summary', plotlyOutput('plot')),
tabPanel('Numerical Summary', verbatimTextOutput('data.pred')),
tabPanel('Model Summary', verbatimTextOutput('summary'))
)
)
)))
----------
**server.R**
server = function(input, output){
observe({if (input$quit == 1)
stopApp()})
limits <- reactive({ if (input$limits) { limits <- c(input$lxlim, input$uxlim) } else {
limits <- limits0 } })
output$manySliders <- renderUI({
slide.bars <- list()
for (j in 1:length(preds)){
if (terms[j+1] == "factor"){
slide.bars[[j]] <- list(selectInput(paste("pred", j, sep = ""), names(preds)[j], preds[[j]]$v.levels, multiple = FALSE))
}
if (terms[j+1] == "numeric"){
if (covariate == "slider") {
slide.bars[[j]] <- list(sliderInput(paste("pred", j, sep = ""), names(preds)[j],
min = preds[[j]]$v.min, max = preds[[j]]$v.max, value = preds[[j]]$v.mean))
}
if (covariate == "numeric") {
slide.bars[[j]] <- list(numericInput(paste("pred", j, sep = ""), names(preds)[j], value = zapsmall(preds[[j]]$v.mean, digits = 4)))
}}}
do.call(tagList, slide.bars)
})
output$setlimits <- renderUI({
if (is.null(DNlimits)){
setlim <- list(checkboxInput("limits", "Set x-axis ranges"),
conditionalPanel(condition = "input.limits == true",
numericInput("uxlim", "x-axis upper", zapsmall(limits0[2], digits = 2)),
numericInput("lxlim", "x-axis lower", zapsmall(limits0[1], digits = 2))))
} else{ setlim <- NULL }
setlim
})
a <- 0
new.d <- reactive({
input$add
input.v <- vector("list", length(preds))
for (i in 1:length(preds)) {
input.v[[i]] <- isolate({
input[[paste("pred", i, sep = "")]]
})
names(input.v)[i] <- names(preds)[i]
}
out <- data.frame(lapply(input.v, cbind))
if (a == 0) {
input.data <<- rbind(input.data, out)
}
if (a > 0) {
if (!isTRUE(compare(old.d, out))) {
input.data <<- rbind(input.data, out)
}}
a <<- a + 1
out
})
p1 <- NULL
old.d <- NULL
data2 <- reactive({
if (input$add == 0)
return(NULL)
if (input$add > 0) {
if (!isTRUE(compare(old.d, new.d()))) {
isolate({
mpred <- getpred.DN(model, new.d(), set.rms=T)$pred
se.pred <- getpred.DN(model, new.d(), set.rms=T)$SEpred
if (is.na(se.pred)) {
lwb <- "No standard errors"
upb <- "by 'lrm'"
pred <- mlinkF(mpred)
d.p <- data.frame(Prediction = zapsmall(pred, digits = 3),
Lower.bound = lwb, Upper.bound = upb)
} else {
lwb <- sort(mlinkF(mpred + cbind(1, -1) * (qnorm(1 - (1 - clevel)/2) * se.pred)))[1]
upb <- sort(mlinkF(mpred + cbind(1, -1) * (qnorm(1 - (1 - clevel)/2) * se.pred)))[2]
pred <- mlinkF(mpred)
d.p <- data.frame(Prediction = zapsmall(pred, digits = 3),
Lower.bound = zapsmall(lwb, digits = 3),
Upper.bound = zapsmall(upb, digits = 3))
}
old.d <<- new.d()
data.p <- cbind(d.p, counter = 1, count=0)
p1 <<- rbind(p1, data.p)
p1$counter <- seq(1, dim(p1)[1])
p1$count <- 0:(dim(p1)[1]-1) %% 11 + 1
p1
})
} else {
p1$count <- seq(1, dim(p1)[1])
}}
rownames(p1) <- c()
p1
})
output$plot <- renderPlotly({
if (input$add == 0)
return(NULL)
if (is.null(new.d()))
return(NULL)
coll=c("#0E0000", "#0066CC", "#E41A1C", "#54A552", "#FF8000", "#BA55D3",
"#006400", "#994C00", "#F781BF", "#00BFFF", "#A9A9A9")
lim <- limits()
yli <- c(0 - 0.5, 10 + 0.5)
dat2 <- data2()
if (dim(data2())[1] > 11){
input.data = input.data[-c(1:(dim(input.data)[1]-11)),]
dat2 <- data2()[-c(1:(dim(data2())[1]-11)),]
yli <- c(dim(data2())[1] - 11.5, dim(data2())[1] - 0.5)
}
in.d <- input.data
xx <- matrix(paste(names(in.d), ": ", t(in.d), sep = ""), ncol = dim(in.d)[1])
Covariates <- apply(xx, 2, paste, collapse = "<br />")
p <- ggplot(data = dat2, aes(x = Prediction, y = counter - 1, text = Covariates,
label = Prediction, label2 = Lower.bound, label3=Upper.bound)) +
geom_point(size = 2, colour = coll[dat2$count], shape = 15) +
ylim(yli[1], yli[2]) + coord_cartesian(xlim = lim) +
labs(title = "95% Confidence Interval for Response",
x = "Probability", y = "") + theme_bw() +
theme(axis.text.y = element_blank(), text = element_text(face = "bold", size = 10))
if (is.numeric(dat2$Upper.bound)){
p <- p + geom_errorbarh(xmax = dat2$Upper.bound, xmin = dat2$Lower.bound,
size = 1.45, height = 0.4, colour = coll[dat2$count])
} else{
message("Confidence interval is not available as there is no standard errors available by 'lrm' ")
}
gp <- ggplotly(p, tooltip = c("text", "label", "label2", "label3"))
gp$elementId <- NULL
gp
})
output$data.pred <- renderPrint({
if (input$add > 0) {
if (nrow(data2()) > 0) {
if (dim(input.data)[2] == 1) {
in.d <- data.frame(input.data)
names(in.d) <- names(terms)[2]
data.p <- cbind(in.d, data2()[1:3])
}
if (dim(input.data)[2] > 1) {
data.p <- cbind(input.data, data2()[1:3])
}}
stargazer(data.p, summary = FALSE, type = "text")
}
})
output$summary <- renderPrint({
print(model)
})
}
----------
**global.R**
library(ggplot2)
library(shiny)
library(plotly)
library(stargazer)
library(compare)
library(prediction)
library(rms)
load('data.RData')
source('functions.R')
t.dist <- datadist(data)
options(datadist = 't.dist')
m.summary <- 'raw'
covariate <- 'numeric'
clevel <- 0.95
I am not quite sure which type of shiny widget (or labels) you mean, but I have some comments.
Firstly, you need to make sure defining your variables' class correctly (e.g. as factors, numeric, ...), for example, by adding the following code before fitting your model:
> data$y <- as.factor(data$y)
This is especially important for factors so it gets factor levels. For numerical variables, you can get a shiny slider (by default) or a numeric input (using covariate = c("numeric")).
The labels for widgets are the same as the variable names. So the easiest way to adjust them is by changing the variable names as you like before fitting your model:
> names(data)
[1] "x" "y" "z"
> names(data)[2] <- 'ylabel'
> names(data)
[1] "x" "ylabel" "z"
> model <- lrm(x ~ ylabel + z, data = data)
Alternatively, the labels can be changed by adjusting the 'preds' object in the 'data.RData'. For example, you can use the following code to change labels:
> names(preds)
[1] "y" "z"
> names(preds)[1] <- 'labelled y'
> names(preds)
[1] "labelled y" "z"
> save.image(file = "data.RData")

Calling additional functions in Shiny

I developed a simple shiny app that take as inputs a score my_x on a distribution with mean my_mean and standard deviation my_sd. As output, the app return a Lattice plot with a Normal Standard distribution with the corresponding z-score of my_x. Please find the code for the app on GitHub.
Now, I would like to add a second functionality to the app:
By checking a checkboxInput I would calculate, for example, the pnorm of the inputs and shade the relative area of the graph.
I wrote the code for the graph (here an example of the expected result), but I cannot figure out how to make it work in Shiny. In particular, I cannot figure how to make the function activated with the checkbox working properly with the first function drawing the graph.
library(lattice)
e4a <- seq(60, 170, length = 10000)
e4b <- dnorm(e4a, 110, 15)
#z-score is calculated with the inputs listed above:
z_score <- (my_x - my_mean)/my_sd
plot_e4d <- xyplot(e4b ~ e4a,
type = "l",
main = "Plot 4",
scales = list(x = list(at = seq(60, 170, 10)), rot = 45),
panel = function(x,y, ...){
panel.xyplot(x,y, ...)
panel.abline(v = c(z_score, 110), lty = 2)
xx <- c(60, x[x>=60 & x<=z_score], z_score)
yy <- c(0, y[x>=60 & x<=z_score], 0)
panel.polygon(xx,yy, ..., col='red')
})
print(plot_e4d)
I found a functioning solution. I am pretty sure that it is not the most efficient, but it works. It consists of an if/else statement within the server function calling the plot. I would like to thank #zx8754 for the inspiration.
Here is the ui.r file:
library(shiny)
shinyUI(pageWithSidebar(
headerPanel("Standard Normal"),
sidebarPanel(
numericInput('mean', 'Your mean', 0),
numericInput('sd', 'Your standard deviation', 0),
numericInput('x', 'Your score', 0),
checkboxInput('p1', label = 'Probability of getting a score smaller than x or z', value = FALSE)
),
mainPanel(
h3('Standard Normal'),
plotOutput('sdNorm'),
h4('Your z-score is:'),
verbatimTextOutput('z'),
h4('Your lower tail probability is:'),
verbatimTextOutput('p1')
))
)
And the server.R file:
library(lattice)
shinyServer(
function(input, output){
output$sdNorm <- renderPlot({
dt1 <- seq(-3, 3, length = 1000)
dt2 <- dnorm(dt1, 0, 1)
my_mean <- input$mean
my_sd <- input$sd
my_x <- input$x
z <- (my_x - my_mean)/my_sd
if(input$p1){
xyplot(dt2 ~ dt1,
type = "l",
main = "Lower tail probability",
panel = function(x,y, ...){
panel.xyplot(x,y, ...)
panel.abline(v = c(z, 0), lty = 2)
xx <- c(-3, x[x>=-3 & x<=z], z)
yy <- c(0, y[x>=-3 & x<=z], 0)
panel.polygon(xx,yy, ..., col='red')
})
}else{
xyplot(dt2 ~ dt1,
type = "l",
main = "Standard Normal Distribution",
panel = function(x, ...){
panel.xyplot(x, ...)
panel.abline(v = c(z, 0), lty = 2)
})
}
})
output$z = renderPrint({
my_mean <- input$mean
my_sd <- input$sd
my_x <- input$x
z <- (my_x - my_mean)/my_sd
z
})
output$p1 <- renderPrint({
if(input$p1){
my_mean <- input$mean
my_sd <- input$sd
my_x <- input$x
p1 <- 1- pnorm(my_x, my_mean, my_sd)
p1
} else {
p1 <- NULL
}
})
}
)
This should work:
library(shiny)
library(lattice)
shinyApp(
ui = {
pageWithSidebar(
headerPanel("Standard Normal"),
sidebarPanel(
numericInput('mean', 'Your mean', 80),
numericInput('sd', 'Your standard deviation', 2),
numericInput('x', 'Your score', 250),
checkboxInput("zScoreArea", label = "Area under z-score", value = TRUE)
),
mainPanel(
h3('Standard Normal'),
plotOutput('sdNorm'),
h4('Your z-score is:'),
verbatimTextOutput('z_score')
))
},
server = {
function(input, output){
#data
dt1 <- seq(60, 170, length = 10000)
dt2 <- dnorm(dt1, 110, 15)
#xyplot panel= function()
myfunc <- reactive({
if(input$zScoreArea){
function(x,y, ...){
panel.xyplot(x,y, ...)
panel.abline( v = c(z_score(), 110), lty = 2)
xx <- c(60, x[x >= 60 & x <= z_score()], z_score())
yy <- c(0, y[x >= 60 & x <= z_score()], 0)
panel.polygon(xx,yy, ..., col='red')
}
}else{
function(x, ...){
panel.xyplot(x, ...)
panel.abline(v = c(z_score(), 110), lty = 2)}
}
})
#reactive z_score for plotting
z_score <- reactive({
my_mean <- input$mean
my_sd <- input$sd
my_x <- input$x
#return z score
(my_x - my_mean)/my_sd
})
output$sdNorm <- renderPlot({
xyplot(dt2 ~ dt1,
type = "l",
main = "Plot 4",
scales = list(x = list(at = seq(60, 170, 10)), rot = 45),
panel = myfunc()
)
})
output$z_score = renderPrint({ z_score() })
}
}
)

R Shiny. "Error: no applicable method for 'xtable' applied to an object of class "c('double', 'numeric')"

I am trying to create an interactive data set and I need to subset it for calculations. When I try to extract certain rows and columns I get this error message about xtable being applied object of class "C('double','numeric')". Here is my code.
ui.r
library(shiny)
require(ggplot2)
shinyUI(fluidPage(
titlePanel("Vasicek Model Example"),
sidebarLayout(
sidebarPanel(
numericInput("sim", "Simulations", value = 100),
numericInput("loans", "Loans", value = 10),
numericInput("M", "Systemic Risk Factor", value = 0),
numericInput("rho", "Firm Correlation", value = 0),
sliderInput("bins", "Number of Bins:", min = 1, max = 50, value = 30),
submitButton("Submit")
),
mainPanel(
tabsetPanel(
tabPanel("Debug", tableOutput("probs"), tableOutput("dftable")),
tabPanel(plotOutput("distPlot"), tableOutput("sumtable"),
tableOutput("tabs"))
)
)
)))
server.r
library(shiny)
require(ggplot2)
shinyServer(function(input,output){
TMo <- reactive({
matrix(c(.90, .05, .04, .01,
.05, .80, .10, .05,
.05, .25, .60, .10,
.00, .00, .00, 1.0), nrow=4, ncol=4, byrow=T)
})
Pprob <- reactive({
TMo()[1:3, 4]
})
output$probs <- renderTable({
Pprob()
})
plotdata <- reactive({
R <- vector()
c <- vector()
DefRate <- vector()
groups <- vector()
ctr <- 0
for(group in 1:3){
c[group] <- qnorm(Pprob()[group])
for(i in 1:input$sim){
e <- matrix(data = rnorm(n = input$loans, mean = 0, sd = 1))
ctr <- ctr + 1
default <- 0
for(j in 1:input$loans){
R[j] <- sqrt(input$rho) * M + sqrt(1 - input$rho) * e[j]
if(R[j] <= c[group]){
default + 1
}
if(j == input$loans){
DefRate[ctr] <- default/input$loans
if(group == 1){
groups[ctr] = 'A'
}
else if(group == 2){
groups[ctr] = 'B'
}
else{
groups[ctr] = 'C'
}
}
if(group == 3 & i == input$sims & j == input$loans){
DefData <- cbind(DefRate,groups)
as.data.frame(DefData)
}
}
}
}
})
output$dftable <- renderTable({
head(plotdata())
})
#output$distPlot <- renderPlot({
#bins <- seq(min(x), max(x), length.out = input$bins + 1)
#DR_plots <- ggplot(DData, aes(x=DData$Default_Rate, fill=DData$Credit_Rating))
#DR_Hist_options <- geom_histogram(binwidth = .01, alpha=.5, position = "identity")
#DR_Hist <- DR_plots + DR_Hist_options
#DR_Hist
#hist(x, breaks = bins, col = 'darkgray', border = 'white',
#main = "Default Rate Distribution", xlab = "Default Rates",
#ylab = "Frequency")
#})
#output$tabs <- renderTable({
#x <- DR_Data
#head(x)
#})
})
excuse the commented out sections. I'm was debugging to try to figure out the source of the problem. Thank you for the help.

Can GGPLOT make 2D summaries of data?

I wish to plot mean (or other function) of reaction time as a function of the location of the target in the x y plane.
As test data:
library(ggplot2)
xs <- runif(100,-1,1)
ys <- runif(100,-1,1)
rts <- rnorm(100)
testDF <- data.frame("x"=xs,"y"=ys,"rt"=rts)
I know I can do this:
p <- ggplot(data = testDF,aes(x=x,y=y))+geom_bin2d(bins=10)
What I would like to be able to do, is the same thing but plot a function of the data in each bin rather than counts. Can I do this?
Or do I need to generate the conditional means first in R (e.g. drt <- tapply(testDF$rt,list(cut(testDF$x,10),cut(testDF$y,10)),mean)) and then plot that?
Thank you.
Update With the release of ggplot2 0.9.0, much of this functionality is covered by the new additions of stat_summary2d and stat_summary_bin.
here is a gist for this answer: https://gist.github.com/1341218
here is a slight modification of stat_bin2d so as to accept arbitrary function:
StatAggr2d <- proto(Stat, {
objname <- "aggr2d"
default_aes <- function(.) aes(fill = ..value..)
required_aes <- c("x", "y", "z")
default_geom <- function(.) GeomRect
calculate <- function(., data, scales, binwidth = NULL, bins = 30, breaks = NULL, origin = NULL, drop = TRUE, fun = mean, ...) {
range <- list(
x = scales$x$output_set(),
y = scales$y$output_set()
)
# Determine binwidth, if omitted
if (is.null(binwidth)) {
binwidth <- c(NA, NA)
if (is.integer(data$x)) {
binwidth[1] <- 1
} else {
binwidth[1] <- diff(range$x) / bins
}
if (is.integer(data$y)) {
binwidth[2] <- 1
} else {
binwidth[2] <- diff(range$y) / bins
}
}
stopifnot(is.numeric(binwidth))
stopifnot(length(binwidth) == 2)
# Determine breaks, if omitted
if (is.null(breaks)) {
if (is.null(origin)) {
breaks <- list(
fullseq(range$x, binwidth[1]),
fullseq(range$y, binwidth[2])
)
} else {
breaks <- list(
seq(origin[1], max(range$x) + binwidth[1], binwidth[1]),
seq(origin[2], max(range$y) + binwidth[2], binwidth[2])
)
}
}
stopifnot(is.list(breaks))
stopifnot(length(breaks) == 2)
stopifnot(all(sapply(breaks, is.numeric)))
names(breaks) <- c("x", "y")
xbin <- cut(data$x, sort(breaks$x), include.lowest=TRUE)
ybin <- cut(data$y, sort(breaks$y), include.lowest=TRUE)
if (is.null(data$weight)) data$weight <- 1
ans <- ddply(data.frame(data, xbin, ybin), .(xbin, ybin), function(d) data.frame(value = fun(d$z)))
within(ans,{
xint <- as.numeric(xbin)
xmin <- breaks$x[xint]
xmax <- breaks$x[xint + 1]
yint <- as.numeric(ybin)
ymin <- breaks$y[yint]
ymax <- breaks$y[yint + 1]
})
}
})
stat_aggr2d <- StatAggr2d$build_accessor()
and usage:
ggplot(data = testDF,aes(x=x,y=y, z=rts))+stat_aggr2d(bins=3)
ggplot(data = testDF,aes(x=x,y=y, z=rts))+
stat_aggr2d(bins=3, fun = function(x) sum(x^2))
As well, here is a slight modification of stat_binhex:
StatAggrhex <- proto(Stat, {
objname <- "aggrhex"
default_aes <- function(.) aes(fill = ..value..)
required_aes <- c("x", "y", "z")
default_geom <- function(.) GeomHex
calculate <- function(., data, scales, binwidth = NULL, bins = 30, na.rm = FALSE, fun = mean, ...) {
try_require("hexbin")
data <- remove_missing(data, na.rm, c("x", "y"), name="stat_hexbin")
if (is.null(binwidth)) {
binwidth <- c(
diff(scales$x$input_set()) / bins,
diff(scales$y$input_set() ) / bins
)
}
try_require("hexbin")
x <- data$x
y <- data$y
# Convert binwidths into bounds + nbins
xbnds <- c(
round_any(min(x), binwidth[1], floor) - 1e-6,
round_any(max(x), binwidth[1], ceiling) + 1e-6
)
xbins <- diff(xbnds) / binwidth[1]
ybnds <- c(
round_any(min(y), binwidth[1], floor) - 1e-6,
round_any(max(y), binwidth[2], ceiling) + 1e-6
)
ybins <- diff(ybnds) / binwidth[2]
# Call hexbin
hb <- hexbin(
x, xbnds = xbnds, xbins = xbins,
y, ybnds = ybnds, shape = ybins / xbins,
IDs = TRUE
)
value <- tapply(data$z, hb#cID, fun)
# Convert to data frame
data.frame(hcell2xy(hb), value)
}
})
stat_aggrhex <- StatAggrhex$build_accessor()
and usage:
ggplot(data = testDF,aes(x=x,y=y, z=rts))+stat_aggrhex(bins=3)
ggplot(data = testDF,aes(x=x,y=y, z=rts))+
stat_aggrhex(bins=3, fun = function(x) sum(x^2))
This turned out to be harder than I expected.
You can almost trick ggplot into doing this, by providing a weights aesthetic, but that only gives you the sum of the weights in the bin, not the mean (and you have to specify drop=FALSE to retain negative bin values). You can also retrieve either counts or density within a bin, but neither of those really solves the problem.
Here's what I ended up with:
## breaks vector (slightly coarser than the 10x10 spec above;
## even 64 bins is a lot for binning only 100 points)
bvec <- seq(-1,1,by=0.25)
## helper function
tmpf <- function(x,y,z,FUN=mean,breaks) {
midfun <- function(x) (head(x,-1)+tail(x,-1))/2
mids <- list(x=midfun(breaks$x),y=midfun(breaks$y))
tt <- tapply(z,list(cut(x,breaks$x),cut(y,breaks$y)),FUN)
mt <- melt(tt)
## factor order gets scrambled (argh), reset it
mt$X1 <- factor(mt$X1,levels=rownames(tt))
mt$X2 <- factor(mt$X2,levels=colnames(tt))
transform(X,
x=mids$x[mt$X1],
y=mids$y[mt$X2])
}
ggplot(data=with(testDF,tmpf(x,y,rt,breaks=list(x=bvec,y=bvec))),
aes(x=x,y=y,fill=value))+
geom_tile()+
scale_x_continuous(expand=c(0,0))+ ## expand to fill plot region
scale_y_continuous(expand=c(0,0))
This assumes equal bin widths, etc., could be extended ... it really is too bad that (as far as I can tell) stat_bin2d doesn't accept a user-specified function.

Resources