Skip to content
Create a gist now

Instantly share code, notes, and snippets.

@dgrapov /global.R
Last active

#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()
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 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"))
)
)
))
@thollenh

I can't get this example to work with the Iris data set. I get "Error: could not find function "devium.pca.calculate". It seems like the pcaMethods package doesn't get fully installed it also says

"Warning message:
package ‘pcaMethods’ is not available (for R version 3.2.2) "

When I try to install pcaMethods package

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Something went wrong with that request. Please try again.