public
Last active

  • Download Gist
global.R
R
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49
#check for and/or install dependencies
need<-c("RCurl","ggplot2","gridExtra","reshape2")
for(i in 1:length(need)){
if(require(need[i], character.only = TRUE)==FALSE){ install.packages(need[i]);library(need[i], character.only = TRUE)} else { library(need[i],character.only = TRUE)}
}
 
if(require(pcaMethods)==FALSE){
need<-c('Rcpp', 'rJava',
'Matrix', 'cluster', 'foreign', 'lattice', 'mgcv', 'survival')
for(i in 1:length(need)){
if(require(need[i], character.only = TRUE)==FALSE){
install.packages(need[i],dependencies=TRUE);library(need[i], character.only = TRUE)
} else { library(need[i],character.only = TRUE)
}
}#dependancies
source("http://bioconductor.org/biocLite.R")
biocLite("pcaMethods")
}
 
#Functions used in example
#---------------------------
#fxn to load repo from from github
source.git.hub<-function(url = "https://github.com/dgrapov/devium/tree/master/R")
{
if(require(RCurl)==FALSE){install.packages("RCurl");library(RCurl)} else { library(RCurl)}
#get the names of all scripts to source
obj<-getURL("https://github.com/dgrapov/devium/tree/master/R",ssl.verifypeer=FALSE)
tmp<-strsplit(obj,'href=\"/')
tmp2<-unlist(strsplit(as.character(unlist(tmp)),'class'))
scripts<-gsub("/blob","",gsub('\" ',"",tmp2[grep("dgrapov/devium/blob/master/R/",tmp2)])) # fix formatting
#add http for git hub
scripts<-paste("https://raw.github.com/",scripts,sep="")
sapply(1:length(scripts),function(i)
{
tryCatch( eval( expr = parse( text = getURL(scripts[i],
ssl.verifypeer=FALSE) ),envir=.GlobalEnv),error=function(e){print(paste("can't load:",scripts[i]))})
})
}
 
#convert vector to named list
namel<-function (vec){
tmp<-as.list(vec)
names(tmp)<-as.character(unlist(vec))
tmp
}
 
# app startup
source.git.hub()
server.R
R
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112
shinyServer(function(input, output, session) {
.theme<- theme(
axis.line = element_line(colour = 'gray', size = .75),
panel.background = element_blank(),
plot.background = element_blank()
)
#file info
output$filetable <- renderTable({
if(is.null(input$files) ) { return() } else {
tmp<-read.csv(input$files$datapath, header=T, stringsAsFactors =T)
tmp<-tmp[,seq_along(1:ncol(tmp))<=10] # show max 10 columns and binf head tail calls
rbind(head(tmp,10),tail(tmp,10))
# input$files
}
})
#confirm load
output$caption<-renderText({
if (!is.null(PCA.results())) {
"Principal Components Analysis"
} else {
if(is.null(input$files)) { "Load Data" } else { "Data Loaded"}
}
})
#number of PCs
output$PCs<-renderUI({
if (is.null(input$files)) { return(NULL) }
maxPCs<-ncol(input$files)
numericInput("PCs", "Number of Principal Components",
2, min = 2, max = maxPCs)
})
PCA.results<-reactive({
if (is.null(input$files)) {
return(NULL)
} else {
# list(data=read.csv(input$files$datapath, header=T, stringsAsFactors =T),
# data2=rnorm(10))
# }
#adapted from another devium
pca.inputs<-list()
start.data<<-read.csv(input$files$datapath, header=T, stringsAsFactors =T)
pca.inputs$pca.data<-"start.data"
pca.inputs$pca.algorithm<-input$method
pca.inputs$pca.components<-input$PCs
pca.inputs$pca.center<-input$center
pca.inputs$pca.scaling<-input$scaling
pca.inputs$pca.cv<-input$cv # currently not used
devium.pca.calculate(pca.inputs,return="list",plot=F)
}
})
#make screeplot
output$screeplot <- renderPlot({
if (is.null(PCA.results())) {
return(NULL)
} else {
x<-PCA.results()
x<-data.frame(x$pca.eigenvalues)
# make.scree.plot(x)
make.scree.plot.bar(x)
}
})
# scores diagnostic plot
output$scores <- renderPlot({
if (is.null(PCA.results())) {
return(NULL)
} else {
tmp<-PCA.results()
scores<-data.frame(tmp$pca.scores)
if(nrow(tmp$pca.diagnostics)==nrow(scores))
{
if(any(tmp$pca.diagnostics$DmodX=="NaN")){tmp$pca.diagnostics$DmodX<-1}
scores<-data.frame(leverage=tmp$pca.diagnostics$leverage, dmodx=tmp$pca.diagnostics$DmodX,scores)
} else {
scores<-data.frame(leverage=1, dmodx=1,scores)
}
p<-ggplot(scores,mapping = aes_string(x = names(scores)[3], y = names(scores)[4],color=names(scores)[1],size=names(scores)[2])) +
scale_size_continuous("DmodX", range = c(4, 10)) +
geom_point(alpha=0.75) +.theme
print(p)
}
})
#loadings plot
output$loadings <- renderPlot({
if (is.null(PCA.results())) {
return(NULL)
} else {
tmp<-PCA.results()
loadings<-data.frame(tmp$pca.loadings,names=rownames(tmp$pca.loadings))
#plot
p<-ggplot(loadings,mapping = aes_string(x = names(loadings)[1], y = names(loadings)[2], label = "names")) +
geom_text(size=4,alpha=0.75) +.theme
print(p)
}
})
})
ui.R
R
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48
# UI for app
shinyUI(pageWithSidebar(
# title
headerPanel("Select Options"),
# h2("Principal Components Analysis (PCA)")
#input
sidebarPanel
(
#data upload
fileInput("files", "Choose File", multiple=TRUE),
uiOutput("PCs"),
# tabsetPanel(id="dist",
# tabPanel("Data", value='norm', textInput("dist1","Xdist1", c("norm"))),
# tabPanel("Analyze", value='unif', textInput("dist2","Xdist2", c("unif")))),
checkboxInput("center","Center",TRUE),
selectInput("scaling","Scale",
list(none = "none", "unit variance" = "uv", pareto = "pareto")
),
selectInput("method","Method",
namel(listPcaMethods())
),
selectInput("cv","cross-validation",
list (none = "none", Q2 = "q2")
)
#helpText("Hints"),
),
 
# uiOutput("variable"), # depends on dataset ( set by output$variable in server.R)
# uiOutput("group"), # depends on dataset ( set by output$group in server.R)
# selectInput("plot.type","Plot Type:",
# list(boxplot = "boxplot", histogram = "histogram", density = "density", bar = "bar")
# ),
# checkboxInput("show.points", "show points", TRUE)
 
# output
mainPanel(
h3(textOutput('caption')),
tabsetPanel(
tabPanel("Data",tableOutput("filetable")),
tabPanel("Scree Plot",plotOutput("screeplot",height = 280*2, width = 250*2)),
tabPanel("Scores Plot",plotOutput("scores")),
tabPanel("Loadings Plot",plotOutput("loadings"))
)
)
))

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.