Nothing
library("shiny")
library("foreign")
library("gridExtra")
library("ggplot2")
library("plotly")
source("weightfunction.R")
shinyServer(function(input, output, session) {
filedata <- reactive({
inFile <- input$file1
if (is.null(inFile))
return(NULL)
return(read.table(inFile$datapath, header=input$header, sep=input$sep, quote=input$quote,fill=TRUE))
})
output$contents <- renderTable({
validate(
need(input$file1 !="NULL", "Please upload a data file."))
filedata()
})
output$selectdigits <- renderUI({
selectInput(inputId = "digits", label="Select the number of significant digits to report.", choices=c(1,2,3,4,5,6,7,8,9,10),selected=c(4),multiple=FALSE)
})
output$selecteffects <- renderUI({
#if(!is.null(filedata())){
colNames <- colnames(filedata())
selectInput(inputId = "effects", label="Select the variable containing your effect sizes.", choices=colNames,multiple=FALSE)#}
#else{
# return()
#}
})
output$selectvariances <- renderUI({
#if(!is.null(filedata())){
colNames <- colnames(filedata())
colNames2 <- colNames[colNames != input$effects] #WORKS
selectInput(inputId = "variances", label="Select the variable containing your sampling variances.", choices=colNames2,multiple=FALSE)#}
# else{
# return()
# }
})
output$thesearemyp <- renderUI({
colNames <- colnames(filedata())
colNames2 <- colNames[colNames != input$effects]
selectInput(inputId = "thesearemyp", label="Select that column.", choices=colNames2,selected=0,multiple=FALSE)
})
output$selectmods <- renderUI({
#if(!is.null(filedata())){
colNames <- colnames(filedata())
colNames2 <- colNames[colNames != input$effects]
colNames3 <- colNames2[colNames2 != input$variances]
selectInput(inputId = "moderators", label="Select any moderator variables to include.", choices=colNames3,multiple=TRUE)#}
#else{
# return()
#}
})
output$selectsteps <- renderUI({
#if(!is.null(filedata())){
selectizeInput(inputId = "steps", label="Select at least one p-value cutpoint to include in your model. To include a cutpoint not provided, type it in and press enter.", choices=c(0.001,
0.005,
0.010,
0.020,
0.025,
0.050,
0.100,
0.200,
0.250,
0.300,
0.350,
0.500,
0.600,
0.650,
0.700,
0.750,
0.800,
0.900,
0.950,
0.975,
0.980,
0.990,
0.995,
0.999),
multiple=TRUE,
selected=c(0.025), options=list(create=TRUE,openOnFocus=TRUE))#}
# else{
# return()
#}
})
output$presetweights <- renderUI({
steps <- c(sort(input$steps),1.00)
lapply(1:length(steps), function(i) {
if(i == 1){
numericInput(paste("weight", i), paste('<', steps[1]), value = 1, width = '25%')
}
numericInput(paste("weight", i), paste(steps[i - 1], "<", steps[i]), value = 1)
})
})
unadjustweightnomods <- reactive({
validate(need(input$file1 !="NULL", "Please upload a data file."),
need(input$effects != 0, "Please enter the column numbers of the data file containing your effect sizes and variances."))
if(length(input$moderators) == 0){
effect <- filedata()[,input$effects]
v <- filedata()[,input$variances]
if(input$selectp==TRUE){
p <- filedata()[,input$thesearemyp]
}
if(input$selectp==FALSE){
p <- 1-pnorm(effect/sqrt(v))
}
unadnomods <- weightfunction(effect=effect, v=v,npred=0, 600, 600, p=p)
unadnomods
}
})
unadjustweightmods <- reactive({
if(length(input$moderators) > 0){
npred <- length(input$moderators)
effect <- filedata()[,input$effects]
v <- filedata()[,input$variances]
number <- length(effect)
# XX <- matrix(nrow=number,ncol=(npred+1))
# XX[,1] <- rep(1,number)
# for(i in 2:(npred+1)){ XX[,i] <- filedata()[,input$moderators[i - 1]] }
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Xx <- matrix(nrow=number,ncol=npred)
# modnames <- rep(0, npred)
# for(i in 1:npred)
# {
# Xx[,i] <- filedata()[,input$moderators[i]]
# modnames[i] <- noquote(paste(c("Xx[,",i,"]","+","Xx[,",i + 1,"]"),collapse=" "))
# }
# XX <- model.matrix(~modnames)
Xx <- matrix(nrow=number,ncol=npred)
Xx <- as.data.frame(Xx)
for(i in 1:npred)
{
Xx[,i] <- filedata()[,input$moderators[i]]
colnames(Xx)[i] <- input$moderators[i]
}
XX <- model.matrix(~., Xx)
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
npred <- dim(XX)[2] - 1
prednames <- colnames(XX)
if(input$selectp==TRUE){
p <- filedata()[,input$thesearemyp]
}
if(input$selectp==FALSE){
p <- 1-pnorm(effect/sqrt(v))
}
unadmods <- weightfunction(effect=effect,
v=v,
npred, steps=600, XX=XX, prednames=prednames, p=p)
unadmods
}
})
adjustweightnomods <- reactive({
if(length(input$moderators) == 0){
effect <- filedata()[,input$effects]
v <- filedata()[,input$variances]
steps <- c(as.numeric(sort(input$steps)),1.00)
if(input$selectp==TRUE){
p <- filedata()[,input$thesearemyp]
}
if(input$selectp==FALSE){
p <- 1-pnorm(effect/sqrt(v))
}
if(input$woods){
weights <- rep(0, length(steps))
for(i in 1:length(steps)){
weights[i] <- eval(parse(text=paste("input$'weight ", i, "'", sep="")))
}
adnomods <- weightfunction(effect=effect, v=v, npred=0, steps=steps, 600, weights=weights, p=p)
}
else{
adnomods <- weightfunction(effect=effect, v=v, npred=0, steps=steps, 600, p=p)
}
adnomods
# format(adnomods, digits=input$digits)
}
})
adjustweightmods <- reactive({
if(length(input$moderators) > 0){
effect <- filedata()[,input$effects]
v <- filedata()[,input$variances]
npred <- length(input$moderators)
steps <- c(as.numeric(sort(input$steps)),1.00)
number <- length(effect)
if(input$selectp==TRUE){
p <- filedata()[,input$thesearemyp]
}
if(input$selectp==FALSE){
p <- 1-pnorm(effect/sqrt(v))
}
# XX <- matrix(nrow=number,ncol=(npred+1))
# XX[,1] <- rep(1,number)
# for(i in 2:(npred+1)){ XX[,i] <- filedata()[,input$moderators[i - 1]] }
Xx <- matrix(nrow=number,ncol=npred)
Xx <- as.data.frame(Xx)
for(i in 1:npred)
{
Xx[,i] <- filedata()[,input$moderators[i]]
colnames(Xx)[i] <- input$moderators[i]
}
XX <- model.matrix(~.,Xx)
npred <- dim(XX)[2] - 1
prednames <- colnames(XX)
if(input$woods){
weights <- rep(0, length(steps))
for(i in 1:length(steps)){
weights[i] <- eval(parse(text=paste("input$'weight ", i, "'", sep="")))
}
admods <- weightfunction(effect=effect, v=v, npred, steps=steps, XX=XX, prednames, weights=weights, p=p)
}
else{
admods <- weightfunction(effect=effect, v=v, npred, steps=steps, XX=XX, prednames, p=p)
}
# format(admods, digits=input$digits)
admods
}
})
output$effects <- renderTable({
validate(need(input$file1 !="NULL", "Please upload a data file."))
})
makedefaultPlot <- function(effect, v){
range_effect <- max(effect) - min(effect)
range_v <- max(sqrt(v)) - min(sqrt(v))
lowbound_effect <- min(effect) - 0.05*range_effect
upbound_effect <- max(effect) + 0.05*range_effect
lowbound_v <- min(sqrt(v)) - 0.05*range_v
upbound_v <- max(sqrt(v)) + 0.05*range_v
plot(sqrt(v),effect, xlim=c(lowbound_v,upbound_v), ylim=c(lowbound_effect, upbound_effect), xlab="Standard Error", ylab="Effect Size")
}
makeotherPlot <- function(effect, v){
range_effect <- max(effect) - min(effect)
range_v <- max(sqrt(v)) - min(sqrt(v))
lowbound_effect <- min(effect) - 0.025*range_effect
upbound_effect <- max(effect) + 0.025*range_effect
lowbound_v <- min(sqrt(v)) - 0.025*range_v
upbound_v <- max(sqrt(v)) + 0.025*range_v
plot(effect,sqrt(v), xlim=c(lowbound_effect,upbound_effect), ylim=c(lowbound_v, upbound_v), xlab="Effect Size", ylab="Standard Error")
}
output$funnelplot <- renderPlot({
validate(need(input$file1 !="NULL", "Please upload a data file."),
need(input$effects !=0, "Please enter the column numbers of the data file containing your effect sizes and variances."))
effect <- filedata()[,input$effects]
v <- filedata()[,input$variances]
steps <- 1 - as.numeric(sort(input$steps))
range_v <- max(sqrt(v)) - min(sqrt(v))
lowbound_v <- min(sqrt(v)) - 0.05*range_v
upbound_v <- max(sqrt(v)) + 0.05*range_v
if(input$flip == FALSE){
if(input$interact == FALSE){
print(makedefaultPlot(effect, v))
if(input$contour == FALSE){
if(input$estimates == TRUE){
abline(h=unadjustweightnomods()[2,2], col="red")
}
if(input$estimates == TRUE && length(input$moderators) > 0){
abline(h=unadjustweightmods()[2,2], col="red")
}
if(input$estimates2 == TRUE){
abline(h=adjustweightnomods()[2,2], col="blue")
}
if(input$estimates2 == TRUE && length(input$moderators) > 0){
abline(h=adjustweightmods()[2,2], col="blue")
}
}
else{
testv <- seq(lowbound_v, upbound_v, 0.01)
for(i in 1:length(steps)){
lines(testv, 0 + -qnorm(steps[i])*testv)
lines(testv, 0 - -qnorm(steps[i])*testv)
# lines(testv, qnorm(steps[i], 0, testv))
}
if(input$estimates == TRUE){
abline(h=unadjustweightnomods()[2,2], col="red")
}
if(input$estimates == TRUE && length(input$moderators) > 0){
abline(h=unadjustweightmods()[2,2], col="red")
}
if(input$estimates2 == TRUE){
abline(h=adjustweightnomods()[2,2], col="blue")
}
if(input$estimates2 == TRUE && length(input$moderators) > 0){
abline(h=adjustweightmods()[2,2], col="blue")
}
}
}
}
else {
print(makeotherPlot(effect, v))
if(input$contour == FALSE){
if(input$estimates == TRUE){
abline(v=unadjustweightnomods()[2,2], col="red")
}
if(input$estimates == TRUE && length(input$moderators) > 0){
abline(v=unadjustweightmods()[2,2], col="red")
}
if(input$estimates2 == TRUE){
abline(v=adjustweightnomods()[2,2], col="blue")
}
if(input$estimates2 == TRUE && length(input$moderators) > 0){
abline(v=adjustweightmods()[2,2], col="blue")
}
}
else{
testv <- seq(lowbound_v, upbound_v, 0.01)
for(i in 1:length(steps)){
lines((0 + -qnorm(steps[i])*testv), testv)
lines((0 - -qnorm(steps[i])*testv), testv)
# lines(qnorm(steps[i], 0, testv), testv)
}
##### NOTE to self -- I never added lines at moderators.
### Possibly should do?
if(input$estimates == TRUE){
abline(v=unadjustweightnomods()[2,2], col="red")
}
if(input$estimates == TRUE && length(input$moderators) > 0){
abline(v=unadjustweightmods()[2,2], col="red")
}
if(input$estimates2 == TRUE){
abline(v=adjustweightnomods()[2,2], col="blue")
}
if(input$estimates2 == TRUE && length(input$moderators) > 0){
abline(v=adjustweightmods()[2,2], col="blue")
}
}
}
}
)
output$plotly <- renderPlot({
validate(need(input$file1 !="NULL", "Please upload a data file."),
need(input$effects !=0, "Please enter the column numbers of the data file containing your effect sizes and variances."))
effect <- filedata()[,input$effects]
v <- filedata()[,input$variances]
steps <- 1 - as.numeric(sort(input$steps))
if(input$flip==FALSE){
range_effect <- max(effect) - min(effect)
range_v <- max(sqrt(v)) - min(sqrt(v))
lowbound_effect <- min(effect) - 0.05*range_effect
upbound_effect <- max(effect) + 0.05*range_effect
lowbound_v <- min(sqrt(v)) - 0.05*range_v
upbound_v <- max(sqrt(v)) + 0.05*range_v
plot(sqrt(v),effect, xlim=c(lowbound_v,upbound_v), ylim=c(lowbound_effect, upbound_effect), xlab="Standard Error", ylab="Effect Size")
if(input$contour==TRUE){
testv <- seq(lowbound_v, upbound_v, 0.01)
for(i in 1:length(steps)){
lines(testv, 0 + -qnorm(steps[i])*testv)
lines(testv, 0 - -qnorm(steps[i])*testv)
}
}
if(input$estimates==TRUE){
abline(h=unadjustweightnomods()[2,2], col="red")
}
if(input$estimates2==TRUE){
abline(h=adjustweightnomods()[2,2], col="blue")
}
}
else{
range_effect <- max(effect) - min(effect)
range_v <- max(sqrt(v)) - min(sqrt(v))
lowbound_effect <- min(effect) - 0.025*range_effect
upbound_effect <- max(effect) + 0.025*range_effect
lowbound_v <- min(sqrt(v)) - 0.025*range_v
upbound_v <- max(sqrt(v)) + 0.025*range_v
plot(effect,sqrt(v), xlim=c(lowbound_effect,upbound_effect), ylim=c(lowbound_v, upbound_v), xlab="Effect Size", ylab="Standard Error")
if(input$contour==TRUE){
testv <- seq(lowbound_v, upbound_v, 0.01)
for(i in 1:length(steps)){
lines((0 + -qnorm(steps[i])*testv), testv)
lines((0 - -qnorm(steps[i])*testv), testv)
}
}
if(input$estimates==TRUE){
abline(v=unadjustweightnomods()[2,2], col="red")
}
if(input$estimates2==TRUE){
abline(v=adjustweightnomods()[2,2], col="blue")
}
}
############################ ADD OPTIONS HERE FOR OTHER CHECKBOXES
######### LINES AT ESTIMATES, CONTOUR LINES
})
output$info <- renderText({
xy_str <- function(e) {
if(is.null(e)) return("NULL\n")
paste0("x=", round(e$x, 1), " y=", round(e$y, 1), "\n")
}
xy_range_str <- function(e) {
if(is.null(e)) return("NULL\n")
paste0("xmin=", round(e$xmin, 1), " xmax=", round(e$xmax, 1),
" ymin=", round(e$ymin, 1), " ymax=", round(e$ymax, 1))
}
pval_str <- function(e) {
if(is.null(e)) return("NULL\n")
paste0("pval=", round((1 - abs(pnorm(e$x/e$y))), digits=2),"\n")
}
paste0(
"click: ", xy_str(input$plot_click),
"dblclick: ", xy_str(input$plot_dblclick),
"hover: ", pval_str(input$plot_hover),
"brush: ", xy_range_str(input$plot_brush)
)
})
output$density <- renderPlot({
validate(need(input$file1 !="NULL", "Please upload a data file."),need(input$effects !=0, "Please enter the column numbers of the data file containing your effect sizes and variances."),need(length(input$moderators) == 0, "Please remove the moderators from your model to view this plot. The plot does not incorporate moderators."))
effect <- filedata()[,input$effects]
v <- filedata()[,input$variances]
steps <- c(as.numeric(sort(input$steps)),1.00)
print(makeDensityPlot(effect, v, steps))
})
######### DENSITY PLOTS HERE TO NEXT LINE #############
makeDensityPlot <- function(effect, v, steps){
######## I THINK this works .... triple and quadruple check the damn thing!
#Identifying appropriate values
vc1 <- unadjustweightnomods()[1,2]
mu1 <- unadjustweightnomods()[2,2]
vc2 <- adjustweightnomods()[1,2]
mu2 <- adjustweightnomods()[2,2]
weights <- adjustweightnomods()[3:(length(steps)+1),2]
cuts <- steps
x_low_lim <- min(effect) - 2
x_up_lim <- max(effect) + 2
# print(c(vc1, mu1, vc2, mu2, weights, cuts, x_low_lim, x_up_lim))
xfull <- seq(x_low_lim,x_up_lim,.01)
########### Trying the harmonic mean from Hoaglin as the average
## conditional variance, rather than the median. The harmonic mean
## actually appears to do a worse job. Weird.
vi <- median(v)
# w <- 1/v
# s_squared <- (length(effect)-1)/( sum( w ) - sum( w^2 / sum( w ) ) )
# vi <- s_squared
###########
fx <- ( 1/(sqrt(2*pi*(vi + vc1))) ) * exp( -1/2*( (xfull - mu1)^2 / (vi + vc1) ) )
yfull <- fx
A0 <- sum(rep(.01,length(xfull))*yfull)
# fx2 <- ( 1/(sqrt(2*pi*(vi + vc2))) ) * exp( -1/2*( (xfull - mu2)^2 / (vi + vc2) ) )
fx2 <- ( 1/(sqrt(2*pi*(vi + vc1))) ) * exp( -1/2*( (xfull - mu1)^2 / (vi + vc1) ) )
testlist <- -1 * qnorm(steps, 0, sqrt(vi + vc2))
testxfull <- findInterval(xfull,sort(testlist))
xlist <- split(xfull, testxfull)
ylist <- split(fx2, testxfull)
weights2 <- rev(c(1, weights))
testyfull <- mapply("*", ylist, weights2)
A1 <- sum(rep(.01,length(unlist(xlist)))*unlist(testyfull))
#Creating the plot
plot(c(x_low_lim,x_up_lim), c(0,(max(as.numeric(unlist(testyfull))/A1)+0.10)), type='n', xlab='Sample Effect Size',
ylab='Density',axes=FALSE,lwd=2,font.lab=2,main='Expected and Adjusted Densities')
box(lwd=2)
axis(side=2,font=2)
axis(side=1,font=2)
abline(c(0,0),lwd=2)
#Drawing unadjusted density
# lines(xfull,yfull,lty=2,lwd=2)
lines(xfull,yfull/A0,lty=2,lwd=2)
# lines(as.numeric(unlist(xlist)), as.numeric(unlist(testyfull)))
lines(as.numeric(unlist(xlist)), as.numeric(unlist(testyfull))/A1)
print("TEST")
}
######################################################
output$funnelplot2 <- renderUI({
plotOutput("funnelplot", width=paste0(input$width, "%"), height=input$height)
})
output$downloadfunnelplot <- downloadHandler(
filename = function(){
paste('funnelplot', Sys.Date(), '.pdf', sep='')
},
content = function(FILE=NULL) {
effect <- filedata()[,input$effects]
v <- filedata()[,input$variances]
pdf(file=FILE)
if(input$flip == FALSE){
print(makedefaultPlot(effect,v))}
else{
print(makeotherPlot(effect,v))
}
dev.off()
}
)
output$unadjustedweightfunction <- renderTable({
if(length(input$moderators) == 0){
format(unadjustweightnomods(), digits=input$digits)
}
else{
format(unadjustweightmods(), digits=input$digits)
}
})
output$questionmark <- renderImage({
list(src = './www/questionmark.png',width=17,height=17, alt = "Question_Mark")
}, deleteFile=FALSE)
output$questionmark2 <- renderImage({
list(src = './www/questionmark.png',width=17,height=17, alt = "Question_Mark")
}, deleteFile=FALSE)
output$adjustedweightfunction <- renderTable({
if(length(input$moderators) == 0){
validate(need(input$file1 !="NULL", "Please upload a data file."),
need(input$effects !=0, "Please enter the column numbers of the data file containing your effect sizes and variances."),
need(input$steps !=0, "Please select at least one p-value cutpoint to include in your model."))
intervaltally <- function(p, steps) {
p1 <- cut(p, breaks=c(-Inf,steps), labels=steps)
return(p1) }
effect <- filedata()[,input$effects]
v <- filedata()[,input$variances]
steps <- c(as.numeric(sort(input$steps)),1.00)
if(input$effects != "NULL") {
if(input$selectp==TRUE){
p <- filedata()[,input$thesearemyp]
}
if(input$selectp==FALSE){
p <- 1-pnorm(effect/sqrt(v))
}
pvalues <- as.numeric(table(intervaltally(p, steps)))
}
format(adjustweightnomods(), digits=input$digits)
# adjustweightnomods()
}
else{
intervaltally <- function(p, steps) {
p1 <- cut(p, breaks=c(-Inf,steps), labels=steps)
return(p1) }
effect <- filedata()[,input$effects]
v <- filedata()[,input$variances]
steps <- c(as.numeric(sort(input$steps)),1.00)
if(input$effects != "NULL") {
if(input$selectp==TRUE){
p <- filedata()[,input$thesearemyp]
}
if(input$selectp==FALSE){
p <- 1-pnorm(effect/sqrt(v))
}
pvalues <- as.numeric(table(intervaltally(p, steps)))
}
format(adjustweightmods(), digits=input$digits)
}
})
output$likelihoodratio <- renderTable({
validate(need(input$file1 !="NULL", "Please upload a data file."),
need(input$effects !=0, "Please enter the column numbers of the data file containing your effect sizes and variances."),
need(input$steps !=0, "Please select at least one p-value cutpoint to include in your model."),
need(input$woods==FALSE, "This is not valid under the Vevea and Woods (2005) model."))
if(length(input$moderators) == 0){
effect <- filedata()[,input$effects]
v <- filedata()[,input$variances]
steps <- c(as.numeric(sort(input$steps)),1.00)
if(input$selectp==TRUE){
p <- filedata()[,input$thesearemyp]
}
if(input$selectp==FALSE){
p <- 1-pnorm(effect/sqrt(v))
}
format(likelihoodfunct(effect=effect, v=v, npred=0, steps=steps, 600,p=p),digits=input$digits)
}
else{
effect <- filedata()[,input$effects]
v <- filedata()[,input$variances]
steps <- c(as.numeric(sort(input$steps)),1.00)
npred <- length(input$moderators)
if(input$selectp==TRUE){
p <- filedata()[,input$thesearemyp]
}
if(input$selectp==FALSE){
p <- 1-pnorm(effect/sqrt(v))
}
number <- length(effect)
XX <- matrix(nrow=number,ncol=(npred+1))
XX[,1] <- rep(1,number)
for(i in 2:(npred+1)){ XX[,i] <- filedata()[,input$moderators[i - 1]] }
format(likelihoodfunct(effect=effect, v=v, npred=npred, steps=steps, XX,p=p),digits=input$digits) }
})
output$samplesizes <- renderTable({
validate(need(input$file1 !="NULL", "Please upload a data file."),
need(input$effects !=0, "Please enter the column numbers of the data file containing your effect sizes and variances."),
need(input$steps !=0,"Please select at least one p-value cutpoint to include in your model."))
effect <- filedata()[,input$effects]
v <- filedata()[,input$variances]
intervaltally <- function(p, steps) {
p1 <- cut(p, breaks=c(-Inf,steps), labels=steps)
return(p1) }
steps <- c(as.numeric(sort(input$steps)),1.00)
if(input$selectp){
p <- filedata()[,input$thesearemyp]
}
else{
p <- 1-pnorm(effect/sqrt(v))
}
pvalues <- as.numeric(table(intervaltally(p, steps)))
format(sampletable(p=p, pvalues=pvalues, steps=steps), digits=input$digits)
})
#toggleModal(session, "samplesizes", toggle="toggle")
output$numberofeffects <- renderTable({
validate(need(input$file1 !="NULL", "Please upload a data file."),
need(input$effects !=0, "Please enter the column numbers of the data file containing your effect sizes and variances."),
need(input$steps !=0,"Please select at least one p-value cutpoint to include in your model."))
effect <- filedata()[,input$effects]
results <- matrix(nrow=1,ncol=1)
results[1,1] <- length(effect)
resultsb <- data.frame(results, row.names=c("k"))
colnames(resultsb) <- c("Total Number of Effects")
format(resultsb, digits=input$digits)
})
})
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.