R sampling app version 4

Continuing from my previous post, R sampling app version 3 [app], here I expand upon the example Shiny app that was presented, which generates random samples from some common probability distributions. I have made a number of changes, big and small, from the previous version.

RshinyIntro4
You can click the image to go to the app page.

The changes: First, I added radio buttons to the sidebar to allow the user to toggle between discrete and continuous distributions. This cleaned up the sidebar panel a bit by only displaying the distribution names for one group of distributions at a time. I also added if(length(input$dist)) statements to output$dist1, output$dist2, output$dist3, and output$plot to reduce errors. The errors did not break the app, but it wasn’t professional to allow those brief flashes of red text to be printed to the screen when first launching the app, which simply resulted from the fact that there is a moment now at launch where input$dist is not yet set to a distribution name.

Next, I elected to retain the option of sample density curve overlays for continuous distributions only. I also increased the default sample size and switched from sliderInput to numericInput in the ui.R script. I added wellPanel calls to the ui.R script to organize/segment the sidebar panel a bit. The final changes included adding a download button for obtaining a pdf of the currently displayed plot and an ‘About’ tab that gives more information about the app. The ‘About’ tab is sourced in from an about.r file.

See my posts, Mathematical notation in R plots and Mathematical notation in R plots 2, for some examples and conveniently supplied R code for displaying the equation of a pdf or pmf on an R plot for many common distributions. The code shown in this post for version 4 of the random sampling app will make use of all these R expressions, but you won’t see the expressions explicitly, so please see the other posts if you are interested in how they work or just copying them for your convenience.

Here is the code that is run to build the workspace file that will be loaded by the app:

n.default <- 500
#discrete r* wrapper functions
rbern <- function(n=n.default,bern.prob=0.5){ rbinom(n=n,size=1,prob=bern.prob) }
rbinom2 <- function(n=n.default,binom.size=10,binom.prob=0.5){ rbinom(n,size=binom.size,prob=binom.prob) }
drunif <- function(n=n.default,drunif.min=0,drunif.max=100,drunif.step=1){ sample(seq(drunif.min,drunif.max,by=drunif.step),size=n,rep=T) }
rgeom2 <- function(n=n.default,geom.prob=0.5){ rgeom(n,prob=geom.prob) }
rhyper2 <- function(n=n.default,hyper.M=10,hyper.N=20,hyper.K=10){ rhyper(nn=n,m=hyper.M,n=hyper.N-hyper.M,k=hyper.K) }
rnbinom2 <- function(n=n.default,nbin.size=10,nbin.prob=0.5){ rnbinom(n,size=nbin.size,prob=nbin.prob) }
rpois2 <- function(n=n.default,poi.lambda=10){ rpois(n,poi.lambda) }
# continuous r* wrapper functions
rbeta2 <- function(n=n.default,beta.shape1=2,beta.shape2=2){ rbeta(n,shape1=beta.shape1,shape2=beta.shape2) }
rcauchy2 <- function(n=n.default,cau.location=0,cau.scale=1){ rcauchy(n,location=cau.location,scale=cau.scale) }
rchisq2 <- function(n=n.default,chisq.df=1){ rchisq(n,df=chisq.df) }
rexp2 <- function(n=n.default,exp.rate=1){ rexp(n=n,rate=exp.rate) }
rf2 <- function(n=n.default,F.df1=1,F.df2=15){ rf(n,df1=F.df1,df2=F.df2) }
rgamma2 <- function(n=n.default,gam.shape=1,gam.rate=1){ rgamma(n,shape=gam.shape,rate=gam.rate) }
rlaplace2 <- function(n=n.default,lap.location=0,lap.scale=1){ rlaplace(n,location=lap.location,scale=lap.scale) }
rlogis2 <- function(n=n.default,logi.location=0,logi.scale=1){ rlogis(n,location=logi.location,scale=logi.scale) }
rpareto2 <- function(n=n.default,pareto.location=1,pareto.shape=3){ rpareto(n,location=pareto.location,shape=pareto.shape) }
rweibull2 <- function(n=n.default,weib.shape=1,weib.scale=1){ rweibull(n,shape=weib.shape,scale=weib.scale) }
rt2 <- function(n=n.default,t.df=15){ rt(n=n,df=t.df) }

# Continuous distribution plotmath expressions:
expr.beta <- expression(italic(paste(displaystyle(f(x)~"="~frac(Gamma(alpha+beta),Gamma(alpha)*Gamma(beta))*x^{alpha-1}*(1-x)^{beta-1})
					~~~~displaystyle(list(paste(0<=x) <=1, atop(paste(0<alpha) <infinity, paste(0<beta) <infinity)))
					)))

expr.cauchy <- expression(italic(paste(displaystyle(f(x)~"="~frac(1,pi*sigma)~frac(1,1+bgroup("(",frac(x-theta,sigma),")")^2))
					~~~~displaystyle(list(paste(-infinity<x) <infinity, atop(paste(-infinity<theta) <infinity, sigma > 0)))
					)))

expr.chisq <- expression(italic(paste(frac(1,2^{frac(nu,2)}*Gamma~bgroup("(",frac(nu,2),")"))*x^{frac(nu,2)-1}*e^{-frac(x,2)}
					~~~~displaystyle(atop(paste(0<=x) <infinity, nu~"="~list(1,2,...)))
					)))

expr.exp <- expression(italic(paste(displaystyle(f(x)~"="~lambda*e^{-lambda*x})
					~~~~displaystyle(atop(paste(0<=x) <infinity,lambda>0))
					)))

expr.F <- expression(italic(paste(displaystyle(f(x)~"="~frac(Gamma~bgroup("(",frac(nu[1]+nu[2],2),")"),Gamma~bgroup("(",frac(nu[1],2),")")~Gamma~bgroup("(",frac(nu[2],2),")"))
					~bgroup("(",frac(nu[1],nu[2]),")")^{frac(nu[1],2)}~frac(x^{frac(nu[1],2)-1},bgroup("(",1+frac(d[1],d[2])*x,")")^{frac(d[1]+d[2],2)}))
					~~~~displaystyle(atop(paste(0<=x) <infinity,list(d[1],d[2])~"="~list(1,2,...)))
					)))

expr.gam <- expression(italic(paste(displaystyle(f(x)~"="~frac(beta^alpha,Gamma(alpha))*x^{alpha-1}*e^{-beta*x})
					~~~~displaystyle(list(paste(0<x) <infinity, atop(paste(0<alpha) <infinity, paste(0<beta) <infinity)))
					)))

expr.lap <- expression(italic(paste(displaystyle(f(x)~"="~frac(1,2*sigma)~e^{-frac(abs(x-mu),sigma)})
					~~~~displaystyle(list(paste(-infinity<x) <infinity, atop(paste(-infinity<mu) <infinity, sigma > 0)))
					)))

expr.logi <- expression(italic(paste(displaystyle(f(x)~"="~frac(1,beta)~frac(e^{-frac(x-mu,beta)},bgroup("[",1+e^{-frac(x-mu,beta)},"]")^2))
					~~~~displaystyle(list(paste(-infinity<x) <infinity, atop(paste(-infinity<mu) <infinity, beta > 0)))
					)))

expr.lognorm <- expression(italic(paste(displaystyle(f(x)~"="~frac(1,x*sigma*sqrt(2*pi))~e^{-frac((log(x)-mu)^2,2*sigma^2)})
					~~~~displaystyle(list(paste(0<x) <infinity, atop(paste(-infinity<log(mu)) <infinity, paste(0<sigma^scriptscriptstyle("2")) <infinity)))
					)))

expr.norm <- expression(italic(paste(displaystyle(f(x)~"="~frac(1,sqrt(2*pi*sigma^scriptscriptstyle("2")))~e^{frac(-1,2*sigma^{scriptscriptstyle("2")})*(x-mu)^scriptscriptstyle("2")})
					~~~~displaystyle(list(paste(-infinity<x) <infinity, atop(paste(-infinity<mu) <infinity, paste(0<sigma^scriptscriptstyle("2")) <infinity)))
					)))

expr.pareto <- expression(italic(paste(displaystyle(f(x)~"="~frac(beta*alpha^beta,x^{beta+1}))
					~~~~displaystyle(atop(paste(alpha<x) <infinity, list(alpha,beta) > 0))
					)))

expr.t <- expression(italic(paste(displaystyle(f(x)~"="~frac(Gamma~bgroup("(",frac(nu+1,2),")"),sqrt(nu*pi)~Gamma~bgroup("(",frac(nu,2),")"))~bgroup("(",1+frac(x^2,nu),")")^{-frac(nu+1,2)})
					~~~~displaystyle(atop(paste(-infinity<x) <infinity, nu > 0))
					)))

expr.unif <- expression(italic(paste(displaystyle(f(x)~"="~frac(1,b-a)
					~~~~displaystyle(paste(-infinity<paste(a<=paste(x<=b))) <infinity))
					)))

expr.weib <- expression(italic(paste(displaystyle(f(x)~"="~frac(k,lambda)~bgroup("(",frac(x,lambda),")")^{k-1}*e^(-x/lambda)^k)
					~~~~displaystyle(atop(paste(0<=x) <infinity, list(k,lambda) > 0))
					)))

# Discrete distribution plotmath expressions:
expr.bern <- expression(italic(paste(displaystyle(P(X~"="~x)~"="~p^x*(1-p)^{1-x})
					~~~~displaystyle(atop(x~"="~list(0,1), paste(0<=p)<=1))
					)))

expr.bin <- expression(italic(paste(displaystyle(P(X~"="~x)~"="~bgroup("(",atop(n,x),")")~p^x*(1-p)^{n-x})
					~~~~displaystyle(atop(x~"="~list(0,1,...,n), paste(0<=p)<=1))
					)))

expr.dunif <- expression(italic(paste(displaystyle(P(X~"="~x)~"="~frac(1,N))
					~~~~displaystyle(x~"="~list(1,2,...,N))
					)))

expr.geom <- expression(italic(paste(displaystyle(P(X~"="~x)~"="~p*(1-p)^x)
					~~~~displaystyle(atop(x~"="~list(1,2,...), paste(0<=p)<=1))
					)))

expr.hgeom <- expression(italic(paste(displaystyle(P(X~"="~x)~"="~frac(bgroup("(",atop(M,x),")")~bgroup("(",atop(N-M,K-x),")"),bgroup("(",atop(N,K),")")))
					~~~~displaystyle(list(x~"="~list(0,1,...,K), atop(paste(M-(N-K)<=x)<=M, list(N,M,K)>=0)))
					)))

expr.nbin <- expression(italic(paste(displaystyle(P(X~"="~x)~"="~frac(Gamma(x+n),Gamma(n)*x*"!")~p^r*(1-p)^x)
					~~~~displaystyle(atop(x~"="~list(0,1,...), paste(0<=p)<=1))
					)))

expr.poi <- expression(italic(paste(displaystyle(P(X~"="~x)~"="~frac(e^{-lambda}*lambda^x,x*"!"))
					~~~~displaystyle(atop(x~"="~list(0,1,...), paste(0<=lambda)<infinity))
					)))

I save this workspace as samplingApp.RData and place it in the directory that contains the ui.R and server.R scripts. Next, we have the updated ui.R script.

tabPanelAbout <- source("about.r")$value
shinyUI(pageWithSidebar(
	headerPanel(
		HTML(
			'<div id="stats_header">
			Distributions of Random Variables
			<a href="http://snap.uaf.edu" target="_blank">
			<img id="stats_logo" align="right" alt="SNAP Logo" src="http://www.snap.uaf.edu/images/snap_acronym_rgb.gif" />
			</a>
			</div>'
		),
		"Distributions of Random Variables"
	),
	sidebarPanel(
		wellPanel( radioButtons("dist.type","Distribution type:",list("Discrete","Continuous"),selected="Discrete") ),
		wellPanel(	uiOutput("distName") ),
		wellPanel(
			numericInput("n","Sample size:",10000),
			uiOutput("dist1"),
			uiOutput("dist2"),
			uiOutput("dist3")
		),
		wellPanel(
			uiOutput("sampDens"),
			uiOutput("BW"),
			downloadButton("dlCurPlot", "Download Graphic"),
			downloadButton('dldat', 'Download Sample')
		)
	),
	mainPanel(
		tabsetPanel(
			tabPanel("Plot",plotOutput("plot",height="auto")),
			tabPanel("Summary",verbatimTextOutput("summary")),
			tabPanel("Table",tableOutput("table")),
			tabPanelAbout()
		)
	)
))

Next we have the updated server.R script.

library(shiny)
pkgs <- c("VGAM")
pkgs <- pkgs[!(pkgs %in% installed.packages()[,"Package"])]
if(length(pkgs)) install.packages(pkgs,repos="http://cran.cs.wwu.edu/")
library(VGAM)
load("samplingApp.RData", envir=.GlobalEnv)

shinyServer(function(input,output){

	output$distName <- renderUI({
		if(input$dist.type=="Discrete"){
			radioButtons("dist","Distribution:",selected="Bernoulli",
				list("Bernoulli"="bern","Binomial"="bin","Discrete Uniform"="dunif","Geometric"="geom","Hypergeometric"="hgeom","Negative Binomial"="nbin","Poisson"="poi") # discrete
			)
		} else if(input$dist.type=="Continuous"){
			radioButtons("dist","Distribution:",selected="Beta",
				list("Beta"="beta","Cauchy"="cauchy","Chi-squared"="chisq","Exponential"="exp","F"="F","Gamma"="gam","Laplace (Double Exponential)"="lap", # continuous
					"Logistic"="logi","Log-Normal"="lognorm","Normal"="norm","Pareto"="pareto","t"="t","Uniform"="unif","Weibull"="weib")
			)
		}
	})
		
	dat <- reactive({
		dist <- switch(input$dist,
			bern=rbern, bin=rbinom2, dunif=drunif, geom=rgeom2, hgeom=rhyper2, nbin=rnbinom2, poi=rpois2, # discrete
			beta=rbeta2, cauchy=rcauchy2, chisq=rchisq2, exp=rexp2, F=rf2, gam=rgamma2, lap=rlaplace2, # continuous
			logi=rlogis2, lognorm=rlnorm, norm=rnorm, pareto=rpareto2, t=rt2, unif=runif, weib=rweibull2,
			)

		def.args <- switch(input$dist,
			# discrete
			bern=c(input$bern.prob),
			bin=c(input$binom.size,input$binom.prob),
			dunif=c(input$drunif.min,input$drunif.max,input$drunif.step),
			geom=c(input$geom.prob),
			hgeom=c(input$hyper.M,input$hyper.N,input$hyper.K),
			nbin=c(input$nbin.size,input$nbin.prob),
			poi=c(input$poi.lambda),
			# continuous
			beta=c(input$beta.shape1,input$beta.shape2),
			cauchy=c(input$cau.location,input$cau.scale),
			chisq=c(input$chisq.df),
			exp=c(input$exp.rate),
			F=c(input$F.df1,input$F.df2),
			gam=c(input$gam.shape,input$gam.rate),
			lap=c(input$lap.location,input$lap.scale),
			logi=c(input$logi.location,input$logi.scale),
			lognorm=c(input$meanlog,input$sdlog),
			norm=c(input$mean,input$sd),
			pareto=c(input$pareto.location,input$pareto.shape),
			t=c(input$t.df),
			unif=c(input$min,input$max),
			weib=c(input$weib.shape,input$weib.scale)
			)

		f <- formals(dist)
		f <- f[names(f)!="nn" & names(f)!="n"]
		if(any(input$dist==c("dunif","hgeom"))){ len <- min(length(f),4-1); f <- f[1:len]
		} else { len <- min(length(f),3-1); f <- f[1:len] }
		argList <- list(n=input$n)
		for(i in 1:len) argList[[names(f)[i]]] <- def.args[i]
		return(list(do.call(dist,argList),names(f)))
	})

	output$dist1 <- renderUI({
	if(length(input$dist)){
		lab <- switch(input$dist,
			bern="Probability:", bin="Size:", dunif="Discrete sequence minimum:", geom="Probability:", hgeom="M:", nbin="Number of successes:",	poi="Mean and Variance:", # discrete
			beta="Alpha:", cauchy="Location:", chisq="Degrees of freedom:", exp="Rate:", F="Numerator degrees of freedom:", gam="Shape:", lap="Location:",
			logi="Location:", lognorm="Mean(log):", norm="Mean:", pareto="Location:",	t="Degrees of freedom:", unif="Minimum:", weib="Shape:"
			)
		ini <- switch(input$dist,
			bern=0.5, bin=10, dunif=0, geom=0.5, hgeom=10, nbin=10, poi=10,	# discrete
			beta=2, cauchy=0, chisq=1, exp=1, F=1, gam=1, lap=0, logi=0, lognorm=0, norm=0, pareto=1,	t=15, unif=0, weib=1 # continuous
			)
		numericInput(dat()[[2]][1],lab,ini)
	}
	})
	
	output$dist2 <- renderUI({
	if(length(input$dist)){
		lab <- switch(input$dist,
			bin="Probability:",	dunif="Discrete sequence maximum:",	hgeom="N:",	nbin="Probability:", # discrete
			beta="Beta:", cauchy="Scale:", F="Denominator degrees of freedom:", gam="Rate:", lap="Scale:", # continuous
			logi="Scale:", lognorm="Standard deviation(log)", norm="Standard deviation:", pareto="Shape:", unif="Maximum:", weib="Scale:"
			)
		ini <- switch(input$dist,
			bin=0.5, dunif=100, hgeom=20, nbin=0.5,
			beta=2, cauchy=1, F=15, gam=1, lap=1, logi=1, lognorm=1, norm=1, pareto=3, unif=1, weib=1
			)
		if(any(input$dist==c("bin","dunif","hgeom","nbin","cauchy","lap","logi","pareto","weib",
							"beta","F","gam","lognorm","norm","unif"))) numericInput(dat()[[2]][2],lab,ini)
	}
	})
	
	output$dist3 <- renderUI({
	if(length(input$dist)){
		lab <- switch(input$dist,
			dunif="Step size:",	hgeom="K:")
		ini <- switch(input$dist,
			dunif=1, hgeom=5)
		if(any(input$dist==c("dunif","hgeom"))) numericInput(dat()[[2]][3],lab,ini)
	}
	})
	
	output$sampDens <- renderUI({
		if(input$dist.type=="Continuous") checkboxInput("density","Sample density curve",FALSE)
	})
	
	output$BW <- renderUI({
		if(length(input$density)){
			if(input$density) numericInput("bw","bandwidth:",1)
		}
	})
	
	doPlot <- function(margins){
		if(length(input$dist)){
			d <- dat()[[1]]
			dist <- input$dist
			n <- input$n
			expr <- get(paste("expr",dist,sep="."))
			par(mar=margins)
			if(input$dist.type=="Discrete"){
				barplot(as.numeric(table(d))/input$n,names.arg=names(table(d)),main=expr,xlab="Observations",ylab="Density",col="orange",cex.main=1.5,cex.axis=1.3,cex.lab=1.3)
			}
			if(input$dist.type=="Continuous"){
				hist(d,main=expr,xlab="Observations",ylab="Density",col="orange",cex.main=1.5,cex.axis=1.3,cex.lab=1.3,prob=T)
				if(length(input$density)) if(input$density & length(input$bw)) lines(density(d,adjust=input$bw),lwd=2)
			}
		}
	}
	
	output$plot <- renderPlot({
		doPlot(margins=c(4,4,10,1))
	},
	height=750, width=1000
	)
	
	output$dlCurPlot <- downloadHandler(
		filename = 'curPlot.pdf',
		content = function(file){
			pdf(file = file, width=11, height=8.5)
			doPlot(margins=c(6,6,10,2))
			dev.off()
		}
	)

	output$dldat <- downloadHandler(
		filename = function() { paste(input$dist, '.csv', sep='') },
		content = function(file) {
			write.csv(data.frame(x=dat()[[1]]), file)
		}
	)
	
	output$summary <- renderPrint({
		summary(dat()[[1]])
	})
	
	output$table <- renderTable({
		data.frame(x=dat()[[1]])
	})
})

Finally, the new script addition is the about.r file. I’ve saved it as a function that can be sourced in and passed to tabsetPanel. I know this would probably be considered a very odd way to do this. Some might say just make this part in straight up html and source it with the shiny package includeHTML function. Well, the mood struck me to just make another R script. I already had R open and was in the mood to dabble with the various HTML-related wrapper functions.

function(){
	tabPanel("About",
		p(style="text-align:justify",'This ',a("Shiny", href="http://www.rstudio.com/shiny/", target="_blank"),' application is version four of an expanding app intended for showing various ways of adding 
		desired complexity to your apps, in small digestible doses.
		The premise of this particular app is not complex. This sampling app simply draws random samples from a number of different probability distributions and plots the samples using
		(almost entirely) base R functions.'),
		p(style="text-align:justify",'The utility is in seeing, from version to version, how we can enhance a Shiny app.
		If you are new to Shiny, I hope you find this series helpful and/or inspirational in creating your own Shiny web applications. Shiny is new to me as well. I too am learning as I go.
		I would be happy for any suggestions of ways to improve my code.'),
		br(),

		HTML('<div style="clear: left;"><img src="http://www.gravatar.com/avatar/52c27b8719a7543b4b343775183122ea.png" alt="" style="float: left; margin-right:5px" /></div>'),
		strong('Author'),
		p('Matthew Leonawicz',br(),
			'Statistician | useR',br(),
			a('Scenarios Network for Alaska and Arctic Planning', href="http://www.snap.uaf.edu/", target="_blank"),
			'|',
			a('Blog', href="https://blog.snap.uaf.edu/", target="_blank")
		),
		br(),
		
		div(class="row-fluid",
			div(class="span3",strong('Other app versions'),
				p(HTML('<ul>'),
					HTML('<li>'),a("Version 1", href="XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", target="_blank"),HTML('</li>'),
					HTML('<li>'),a("Version 2", href="XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", target="_blank"),HTML('</li>'),
					HTML('<li>'),a("Version 3", href="XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", target="_blank"),HTML('</li>'),
				HTML('</ul>')),
				strong('Code'),
				p('Source code available at',
				a('GitHub', href='https://github.com/ua-snap/shiny-apps/tree/master/RVdistsExampleAppV4')),
				br()
			),
			div(class="span3", strong('Related blog posts'),
				p(HTML('<ul>'),
					HTML('<li>'),a("Introducing R Shiny Applications", href="XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", target="_blank"),HTML('</li>'),
					HTML('<li>'),a("R Sampling App Version 2", href="XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", target="_blank"),HTML('</li>'),
					HTML('<li>'),a("R Sampling App Version 3", href="XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", target="_blank"),HTML('</li>'),
					HTML('<li>'),a("R Sampling App Version 4", href="XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", target="_blank"),HTML('</li>'),
					HTML('<li>'),a("Mathematical Notation in R Plots", href="https://blog.snap.uaf.edu/2013/03/25/mathematical-notation-in-r-plots/", target="_blank"),HTML('</li>'),
					HTML('<li>'),a("Mathematical Notation in R Plots 2", href="XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", target="_blank"),HTML('</li>'),
				HTML('</ul>')),
				br()
			),
			div(class="span3",
				strong('References'),
				p(HTML('<ul>'),
					HTML('<li>'),a('R', href="http://www.r-project.org/", target="_blank"),HTML('</li>'),
					HTML('<li>'),a("Shiny", href="http://www.rstudio.com/shiny/", target="_blank"),HTML('</li>'),
					HTML('<li>'),a('VGAM', href="http://cran.r-project.org/web/packages/VGAM/index.html", target="_blank"),HTML('</li>'),
				HTML('</ul>'))
			)
		)
	)
}

Go to version 4 of the sampling app. I do not currently have plans for a version 5. But when I have time to think of nice features to add or improvements to make, I’ll do so.

This entry was posted by Matt Leonawicz.

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s

%d bloggers like this: