treespace/ 0000755 0001762 0000144 00000000000 13231640221 012217 5 ustar ligges users treespace/inst/ 0000755 0001762 0000144 00000000000 13213466220 013201 5 ustar ligges users treespace/inst/shiny/ 0000755 0001762 0000144 00000000000 13164413032 014331 5 ustar ligges users treespace/inst/shiny/ui.R 0000644 0001762 0000144 00000144513 13225424527 015112 0 ustar ligges users options(rgl.useNULL=TRUE)
## CHECKS ##
require("scatterD3")
require("shiny")
require("rgl")
require("RLumShiny")
require("shinyBS")
## DEFINE UI ##
shinyUI(
navbarPage("",position="fixed-top", collapsible = TRUE,
theme = "bootstrap.simplex.css",
tabPanel("Tree landscape explorer",
tags$link(rel = 'stylesheet', type = 'text/css', href = 'styles.css'),
tags$style(type="text/css", "body {padding-top: 40px;}"),
pageWithSidebar(
## TITLE ##
headerPanel(
img(src="img/logo.png", height="160")
),
## SIDE PANEL CONTENT ##
sidebarPanel(
tags$head(tags$style(
type = 'text/css',
'form.well { max-height: 1600px; overflow-y: auto; }'
)),
## SPECIFIC TO TREE LANDSCAPE EXPLORER ##
conditionalPanel(condition = "$('li.active a').first().html()== 'Tree landscape explorer'",
## INPUT
## choice of type of data source
img(src="img/line.png", width="100%"),
h2(HTML(' > Input ')),
radioButtons("datatype", HTML(' Choose data source:'),
list("Example: Dengue fever"="exDengue",
"Example: Woodmice"="exWoodmice",
"Input file"="file")),
## choice of dataset if source is a file
conditionalPanel(condition = "input.datatype=='file'",
fileInput("datafile", p(HTML(' Choose input file:'), br(),
strong("accepted formats:"), br(),
em("- multiphylo"), "saved from R (.RData/.rda/.rds)", br(),
em("- nexus"), "file (.nex/.nexus)")
),
checkboxInput("randSamp","Randomly sample from the trees?", value=TRUE),
bsTooltip("randSamp", "For large sets of trees and/or trees with many tips the app may be slow, so beginning the analysis with a small random sample is recommended.",
placement = "right", trigger = "hover", options = NULL),
conditionalPanel(
condition="input.randSamp",
sliderInput("sampleSize", "Size of random sample:", value=10, min=10, max=300, step=10)
)
),
## ANALYSIS
img(src="img/line.png", width="100%"),
h4(HTML(' > Analysis ')),
## choose metric
selectInput("treemethod", "Choose a tree summary:",
choices=c(
"Kendall Colijn (rooted)" = "metric",
"Billera, Holmes, Vogtmann (rooted, uses branch lengths)" = "BHV",
"Kuhner & Felsenstein branch score distance (unrooted, uses branch lengths)" = "KF",
"Robinson Foulds symmetric difference (unrooted, topological)" = "RF",
"Weighted Robinson Foulds (unrooted, uses branch lengths)" = "wRF",
"Steel & Penny tip-tip distance (unrooted, topological)" = "nNodes",
"Steel & Penny weighted tip-tip distance (unrooted, uses branch lengths)" = "patristic",
"Abouheif test (rooted, topological)" = "Abouheif",
"Sum of direct descendents (rooted, topological)" = "sumDD")),
## lambda, axes
uiOutput("lambda"),
bsTooltip("lambda","When lambda=0 trees are compared topologically; increasing lambda gives more focus to branch lengths"),
conditionalPanel(
condition="input.plotType==1",
uiOutput("naxes")
## Future: highlight median trees (if plotType==1)
#checkboxInput("showMedians", label=strong("Highlight median tree(s)?"), value=FALSE)
),
## show Shepard plot?
checkboxInput("quality", label=strong("Assess quality of projection (Shepard plot)?"), value=FALSE),
bsTooltip("quality","A Shepard plot gives an indication of the quality of the MDS projection. It will be displayed below the main plot.", placement="right"),
## show screeplot?
conditionalPanel(
condition="input.graphics==1",
checkboxInput("scree", label=strong("Show screeplot?"), value=FALSE),
bsTooltip("scree","Display screeplot of the eigenvalues associated with each componenet? It will be displayed below the main plot.", placement="right")
),
## find clusters?
checkboxInput("findClusters", label=strong("Identify clusters?"), value=FALSE),
bsTooltip("findClusters","Statistical tools for choosing an appropriate clustering method and number of clusters will be added to treespace soon.", placement="right"),
conditionalPanel(condition ="input.findClusters",
radioButtons("clusterType", label="Method:",
choices=c("statistically"="stat","by metadata"="meta"), selected="stat"),
conditionalPanel(
condition="input.clusterType=='stat'",
## clustering method
selectInput("clustmethod", "Clustering method:",
choices=c(
"Ward" = "ward.D2",
"Single" = "single",
"Complete" = "complete",
"UPGMA" = "average")),
## number of clusters
uiOutput("nclust")
),
conditionalPanel(
condition="input.clusterType=='meta'",
fileInput("metadatafile", p(HTML(' Choose input file:'), br(),
strong("accepted formats:"), br(),
em("- object of class factor/numeric/character/list"), "saved from R (.RData/.rda)", br(),
em("- csv file"), "(.csv) (first column will be used)")
)
)
),
## relevant if method = KC metric, allow tip emphasis
conditionalPanel(
condition="input.treemethod=='metric'",
## Emphasise tips
checkboxInput("emphTips", label=strong("Emphasise tips?"), value=FALSE),
bsTooltip("emphTips","Choose tips to emphasise or de-emphasise: the vector elements corresponding to these tips are multiplied by the weight chosen below.", placement="right"),
## if tip emphasis is chosen, provide options:
conditionalPanel(
condition="input.emphTips",
uiOutput("whichTips"),
sliderInput("emphWeight", "Weight of emphasis", value=2,min=0.1,max=100)
)
),
## AESTHETICS
img(src="img/line.png", width="100%"),
h2(HTML(' > Aesthetics ')),
## tree landscape or compare to single reference tree
conditionalPanel(
condition="input.plot3D==2",
radioButtons("plotType", "View",
choices=c("Full tree landscape"=1,"Distances from a reference tree"=2),
selected=1),
bsTooltip("plotType", "Choose whether to view the relative distances between all trees, or a 1-dimensional plot of their distances from a fixed reference tree")
),
## Dimensions (3D possible if 3 or more axes retained, and full tree landscape)
conditionalPanel(condition="input.naxes>2",
conditionalPanel(
condition="input.plotType==1",
radioButtons("plot3D", "Plot dimensions",
choices=c("2D"=2,"3D"=3),
selected=2)
)
),
conditionalPanel(
condition="(input.plot3D==2)&&(input.plotType==1)",
radioButtons("graphics", "Display using",
choices=c("plotGrovesD3"=1,"plotGroves"=2),
selected=1),
bsTooltip("graphics", "Choose whether to view the tree landscape using plotGrovesD3 which uses scatterD3 (interactive html) or plotGroves which uses adegraphics")
),
# if plotType=1, pick the axes to view:
conditionalPanel(
condition="input.plotType==1",
## select first axis to plot
numericInput("xax", "Indicate the x axis", value=1, min=1, max=3),
## select second axis to plot
numericInput("yax", "Indicate the y axis", value=2, min=1, max=3),
bsTooltip("yax", "If multiple MDS axes have been retained, any combination of axes can be viewed"),
## if in 3D, need a z axis:
conditionalPanel(condition="input.plot3D==3",
numericInput("zax", "Indicate the z axis", value=3, min=1, max=3)
)
),
## aesthetics for tree landscape view
conditionalPanel(
condition="input.plotType==1",
conditionalPanel(
condition="(input.plot3D==2)&&(input.graphics==1)",
## Animate transitions?
checkboxInput("transitions", label="Animate transitions?", value=TRUE)
),
conditionalPanel(
condition="(input.plot3D==2)&&(input.graphics==2)",
## convex hulls or ellipses when clusters identified
conditionalPanel(
condition="input.findClusters",
radioButtons("scattertype", "Type of scatterplot",
choices=c("chull","ellipse"),
selected="chull")
),
selectInput("screemds", "Position of the MDS screeplot:",
choices=c("None" = "none",
"Bottom right" = "bottomright",
"Bottom left" = "bottomleft",
"Top right" = "topright",
"Top left" = "topleft"),
selected="bottomleft")
),
## symbol size
sliderInput("pointsize", "Size of the points", value=2, min=0, max=10, step=0.2),
conditionalPanel(
condition="(input.plot3D==2)&&(input.graphics==1)",
## symbol size
sliderInput("pointopacity", "Opacity of the points", value=0.6, min=0, max=1, step=0.05)
),
conditionalPanel(
condition="input.plot3D==2",
## display labels
checkboxInput("showlabels", label="Display tree labels?", value=FALSE),
conditionalPanel(
condition="input.showlabels",
## label size
sliderInput("labelsize", "Size of the labels", value=1, min=0, max=10, step=1),
conditionalPanel(
condition="input.graphics==2",
checkboxInput("optimlabels", label="Optimize label position?", value=FALSE)
)
)
)
),
# if plotType=2, option to stretch
conditionalPanel(
condition="input.plotType==2",
uiOutput("selectedRefTree"),
sliderInput("stretch", "Height of plot (pixels)", value=1600, min=800, max=12800, step=200)
),
## choose color palette (if clusters detected)
conditionalPanel(
## condition
condition="input.findClusters",
selectInput("palette", "Palette for the clusters",
choices=c("funky", "spectral",
"seasun", "lightseasun", "deepseasun",
"rainbow", "azur", "wasp"),
selected="funky")
),
conditionalPanel(
condition="input.plotType==1",
## choose label colors
jscolorInput("labcol", "Label / point color", value="#1B2266", close=TRUE)
),
br(),br(),br(),br(),br(),br(),br(), # add some blank space at the end of side panel
br(),br(),br(),br(),br(),br(),br(), # add some blank space at the end of side panel
width=4)), # end conditional panel and sidebarPanel; width is out of 12
## MAIN PANEL
mainPanel("",
# TITLE #
h2(HTML(' Tree landscape explorer ')),
br(),br(),
## function I was using for testing:
#verbatimTextOutput("plot_click"),
# Removed:
#verbatimTextOutput("caption"),
conditionalPanel(
condition="input.plot3D==2",
uiOutput("treespacePlot")
),
conditionalPanel(
condition="input.plot3D==3",
rglwidgetOutput("treespacePlot3D", width="800px")
),
conditionalPanel(
condition="(input.plotType==1)&&(input.plot3D==2)&&(input.graphics==1)",
tags$p(actionButton("scatterD3-reset-zoom", HTML(" Reset Zoom")))
),
conditionalPanel(
condition="input.quality",
uiOutput("shep")
),
conditionalPanel(
condition="(input.scree)&&(input.graphics==1)",
uiOutput("scree")
),
br(), br(),
## OUTPUT (save)
img(src="img/line.png", width="400px"),
h2(HTML(' > Output ')),
## save MDS plot
conditionalPanel(
condition="(input.plotType==1)&&(input.plot3D==2)&&(input.graphics==1)",
tags$p(tags$a(id = "scatterD3-svg-export", href = "#",
class = "btn btn-default", HTML(" Save treespace plot as svg"))),
downloadButton("downloadMDS2Dhtml", "Save treespace plot as interactive html")
),
conditionalPanel(
condition="(input.plotType==1)&&(input.plot3D==2)&&(input.graphics==2)",
downloadButton("downloadMDS", "Save treespace image as png file")
),
conditionalPanel(
condition="input.plot3D==3",
downloadButton("downloadMDS3Dhtml", "Save treespace 3D plot as interactive html")
),
conditionalPanel(
condition="input.quality",
downloadButton("downloadShep", "Save Shepard plot as png file")
),
conditionalPanel(
condition="input.scree",
downloadButton("downloadScree", "Save screeplot as png file")
),
## save trees to nexus file
downloadButton('exporttrees', "Save trees to nexus file"),
## save results to csv
downloadButton('exportrestocsv', "Save results (MDS+clusters) to csv file"),
## save results to RData
downloadButton('exportrestordata', "Save results (MDS+clusters) to R object")
) # end mainPanel
) # end page with sidebar
), # end tabPanel
tabPanel("Tree viewer",
tags$link(rel = 'stylesheet', type = 'text/css', href = 'styles.css'),
tags$style(type="text/css", "body {padding-top: 40px;}"),
pageWithSidebar(
## TITLE ##
headerPanel(
img(src="img/logo.png", height="160")
),
## SIDE PANEL CONTENT ##
sidebarPanel(
tags$head(tags$style(
type = 'text/css',
'form.well { max-height: 1600px; overflow-y: auto; }'
)),
## INPUT
## choice of tree type
img(src="img/line.png", width="100%"),
h2(HTML(' > Input ')),
h2(HTML(' >> Tree view ')),
radioButtons("treePlotType", "View",
choices=c("Single tree"=1,"Two tree comparison"=2),
selected=1, width="100%"),
bsTooltip("treePlotType", "Choose whether to view a single tree or two trees side by side with their differences highlighted."),
h2(HTML(' >> Tree selection ')),
conditionalPanel(condition = "input.treePlotType==1",
radioButtons("treeChoice", "Selection",
choices=c("Median tree"="med","General tree selection"="gen"),
selected="med", width="100%"),
bsTooltip("treeChoice", "A geometric median tree is plotted by default. If clusters have been identified, the median for each can be viewed. Alternatively, any individual tree can be plotted."),
conditionalPanel(condition = "input.treeChoice=='med'",
selectInput("selectedMedTree", "Median tree from:",
choices=c("All trees"="all"))
),
conditionalPanel(condition = "input.treeChoice=='gen'",
uiOutput("selectedGenTree")
)
), # end single tree choice
conditionalPanel(condition = "input.treePlotType==2",
radioButtons("treeChoice1", "Select first tree",
choices=c("Median tree"="med","General tree selection"="gen"),
selected="med", width="100%"),
bsTooltip("treeChoice1", "Plot a geometric median tree or any individual tree"),
conditionalPanel(condition = "input.treeChoice1=='med'",
selectInput("selectedMedTree1", "Median tree from:",
choices=c("All trees"="all"))
),
conditionalPanel(condition = "input.treeChoice1=='gen'",
uiOutput("selectedGenTree1")
),
radioButtons("treeChoice2", "Select second tree",
choices=c("Median tree"="med","General tree selection"="gen"),
selected="med", width="100%"),
bsTooltip("treeChoice2", "Plot a geometric median tree or any individual tree"),
conditionalPanel(condition = "input.treeChoice2=='med'",
selectInput("selectedMedTree2", "Median tree from:",
choices=c("All trees"="all"))
),
conditionalPanel(condition = "input.treeChoice2=='gen'",
uiOutput("selectedGenTree2")
),
checkboxInput("showTipDiffTable", label="Display table of tip differences?", value=FALSE)
), # end tree comparison choices
## TREE AESTHETICS
img(src="img/line.png", width="100%"),
h2(HTML(' > Aesthetics ')),
## condition on tree being displayed
conditionalPanel(condition = "input.selectedTree!=''",
## use edge lengths?
checkboxInput("edgelengths", label="Use original branch lengths?", value=TRUE),
## ladderize
checkboxInput("ladderize", label="Ladderize the tree(s)?", value=TRUE),
## type of tree
radioButtons("treetype", "Type of tree",
choices=c("phylogram","cladogram", "fan", "unrooted", "radial"),
selected="phylogram", width="100%"),
conditionalPanel(condition = "input.treePlotType==1",
## tree direction
radioButtons("treedirection", "Direction of the tree",
choices=c("rightwards", "leftwards", "upwards", "downwards"),
selected="rightwards", width="100%")
),
conditionalPanel(condition = "input.treePlotType==2",
## trees facing?
radioButtons("treesFacing", "Direction of trees",
choices=c("facing"=T, "rightwards"=F),
selected=T, width="100%")
),
## tip labels
checkboxInput("showtiplabels", label="Display tip labels?", value=TRUE),
conditionalPanel(condition="input.showtiplabels",
## tip label font
selectInput("tiplabelfont", "Tip label font",
choices=c("Plain"=1,"Bold"=2,"Italic"=3,"Bold italic"=4), selected=1),
## tip label size
sliderInput("tiplabelsize", "Size of the tip labels", value=1, min=0, max=5, step=0.1),
conditionalPanel(condition="input.treePlotType==1",
## tip label colour
jscolorInput("tiplabelcolour", "Tip label colour", value="#000000", close=TRUE)
),
conditionalPanel(condition="input.treePlotType==2",
selectInput("colourMethod", "Colouring method",
choices=c("Gradual colour ramp"=1,"Palette from adegenet"=2),
selected=1),
## basic tip label colour
jscolorInput("basetiplabelcolour", "Label colour for tips with same ancestry", value="#BEBEBE", close=TRUE),
conditionalPanel(condition="input.colourMethod==1",
## basic tip label colour
jscolorInput("minortiplabelcolour", "Label colour for tips with smaller ancestral differences", value="#FFDAB9", close=TRUE),
## basic tip label colour
jscolorInput("majortiplabelcolour", "Label colour for tips with greater ancestral differences", value="#EE0000", close=TRUE)
),
conditionalPanel(condition="input.colourMethod==2",
selectInput("tipPalette", "Palette",
choices=c("funky"=1, "spectral"=2,
"seasun"=3, "lightseasun"=4, "deepseasun"=5,
"rainbow"=6, "azur"=7, "wasp"=8),
selected=2)
)
)
),
## edge width
sliderInput("edgewidth", "Width of the edges", value=2, min=1, max=20, step=0.2),
## edge colour
jscolorInput("edgecolor", "Edge colour", value="#000000", close=TRUE),
br(),br(),br(),br(),br(),br(),br(), # add some blank space at the end of side panel
br(),br(),br(),br(),br(),br(),br(), # add some blank space at the end of side panel
width=4)), # end conditional panel and sidebarPanel; width is out of 12
## MAIN PANEL
mainPanel("",
# TITLE #
h2(HTML(' Tree viewer ')),
br(),br(),
## conditional panel: plot single tree if needed
conditionalPanel(condition = "(input.treePlotType==1)&&(input.selectedTree!='')",
plotOutput("tree", height = "800px"),
br(), br(),
## OUTPUT (save)
img(src="img/line.png", width="400px"),
h2(HTML(' > Output ')),
downloadButton("downloadTree", "Save tree image"),
br(), br()
), # end single tree conditional panel
## conditional panel: plot tree comparison if needed
conditionalPanel(condition = "(input.treePlotType==2)&&(input.selectedTree1!='')&&(input.selectedTree2!='')",
plotOutput("treeDiff", height = "800px"),
# conditional panel: show tip differences table:
conditionalPanel(condition = "input.showTipDiffTable",
tableOutput("tipDiffTable")
),
br(), br(),
## OUTPUT (save)
img(src="img/line.png", width="400px"),
h2(HTML(' > Output ')),
downloadButton("downloadTreeDiff", "Save tree comparison image"),
# conditional panel: show tip differences table:
conditionalPanel(condition = "input.showTipDiffTable",
downloadButton("downloadTipDiffTable", "Save tip differences table")
),
br(), br()
), # end tree comparison conditional panel
## Repeat of treespace plot, for reference
img(src="img/line.png", width="400px"),
h2(HTML(' > Copy of scatter plot ')),
br(), br(),
uiOutput("treespacePlotTreeTab")
) # end mainPanel
) # end page with sidebar
), # end tabPanel "Tree Viewer"
tabPanel("densiTree viewer",
tags$link(rel = 'stylesheet', type = 'text/css', href = 'styles.css'),
tags$style(type="text/css", "body {padding-top: 40px;}"),
pageWithSidebar(
## TITLE ##
headerPanel(
img(src="img/logo.png", height="160")
),
## SIDE PANEL CONTENT ##
sidebarPanel(
tags$head(tags$style(
type = 'text/css',
'form.well { max-height: 1600px; overflow-y: auto; }'
)),
## INPUT
## choice of tree type
img(src="img/line.png", width="100%"),
h2(HTML(' > Input ')),
## add densiTree selector (gets updated to number of clusters by )
selectInput("selectedDensiTree", "Choose collection of trees to view in densiTree plot",
choices=c("Choose one"="","All trees"="all"), width="100%"),
#h2(HTML(' Note: this can be slow for large sets of trees ')),
bsTooltip("selectedDensiTree", "View all trees together in a densiTree plot. If clusters have been identified, the set of trees from a single cluster can be plotted. Note this function can be slow if many trees are included.", placement="bottom"),
## DENSITREE AESTHETICS
img(src="img/line.png", width="100%"),
h2(HTML(' > Aesthetics ')),
conditionalPanel(condition = "input.selectedDensiTree!=''",
## alpha (semitransparency of edges)
sliderInput("alpha", "Transparency of edges", value=0.5, min=0, max=1, step=0.05),
checkboxInput("scaleX", label="Scale trees to equal heights?", value=FALSE),
br(),br(),br(),br(),br(),br(),br(), # add some blank space at the end of side panel
br(),br(),br(),br(),br(),br(),br(), # add some blank space at the end of side panel
width=4)), # end conditional panel and sidebarPanel; width is out of 12
## MAIN PANEL
mainPanel("",
# TITLE #
h2(HTML(' densiTree viewer ')),
br(),br(),
## conditional panel: plot tree if needed
conditionalPanel(condition = "input.selectedDensiTree!=''",
plotOutput("densiTree", height = "800px"),
br(), br(),
## OUTPUT (save)
img(src="img/line.png", width="400px"),
h2(HTML(' > Output ')),
downloadButton("downloadDensiTree", "Save densiTree image"),
br(), br(), br(), br(), br(), br()
) # end densiTree conditional panel
) # end of main panel "Multi-tree viewer"
) # end of page with sidebar
),# end of tabPanel "densiTree viewer"
## HELP SECTION
tabPanel("Help",
tags$style(type="text/css", "body {padding-top: 40px;}"),
HTML(paste(readLines("www/html/help.html"), collapse=" "))
),
## SERVER INFO ##
tabPanel("System info",
tags$style(type="text/css", "body {padding-top: 40px;}"),
verbatimTextOutput("systeminfo"))
) # end of tabsetPanel
) # end of Shiny UI
treespace/inst/shiny/server.R 0000644 0001762 0000144 00000111745 13225424306 015777 0 ustar ligges users ## DEFINE THE SERVER SIDE OF THE APPLICATION
shinyServer(function(input, output, session) {
## LOAD PACKAGES
require("ade4")
require("adegenet")
require("adegraphics")
require("ape")
require("distory")
require("fields")
require("htmlwidgets")
require("MASS")
require("phangorn")
require("treespace")
# suppress warning messages from creating temporary directories when 3d plotting
suppressWarnings(warning("dir.create(dir)"))
# the following resets the DensiTree plot every time the number of clusters changes - it was really slow without this
rvs <- reactiveValues(showDensiTree=NULL)
observeEvent(input$nclust, {
rvs$showDensiTree <- NULL
})
observeEvent(input$selectedDensiTree, {
rvs$showDensiTree <- 1
})
######################################
### Define main reactive functions
######################################
getDataType <- reactive({
input$datatype
})
getDataSet <- reactive({
dataType <- getDataType()
if(dataType=="exDengue"){
return("Dengue")
}
if(dataType=="exWoodmice"){
return("woodmiceTrees")
}
else {
# extract file name
strsplit(input$datafile$name, '[.]')[[1]][1]
}
})
getSampleSize <- reactive({
input$sampleSize
})
getRandSamp <- reactive({
input$randSamp
})
## GET DATA ##
getData <- reactive({
out <- NULL
dataType <- getDataType()
samp <- NULL
## data is a distributed dataset
if(dataType=="exDengue"){
if (!exists("DengueTrees")) {
data("DengueTrees", package="treespace", envir=environment()) }
out <- get("DengueTrees")
}
if(dataType=="exWoodmice"){
if (!exists("woodmiceTrees")) {
data("woodmiceTrees", package="treespace", envir=environment()) }
out <- get("woodmiceTrees")
}
## data is an input file
if(dataType=="file" && !is.null(input$datafile)){
## need to rename input file
oldName <- input$datafile$datapath
extension <- adegenet::.readExt(input$datafile$name)
newName <- paste(input$datafile$datapath, extension, sep=".")
file.rename(oldName, newName)
if(tolower(extension) %in% c("rdata","rda")){
out <- get(load(newName))
}
if(tolower(extension) %in% c("rds")){
out <- readRDS(file=newName)
}
if(tolower(extension) %in% c("nex", "nexus")){
if(!require(ape)) stop("ape is required to read in NEXUS (.nex, .nexus) files")
out <- read.nexus(file=newName)
}
l <- length(out)
## fix potential bug with input of two trees
validate(
need(l>2, "treespace expects at least three trees. The function treeDist is suitable for comparing two trees.")
)
# get a manageable number of trees by sampling if necessary
randSamp <- getRandSamp()
if(randSamp == TRUE){
sampleSize <- getSampleSize()
if (l>sampleSize) {
updateSliderInput(session, "sampleSize", "Size of random sample:", value=sampleSize, min=10, max=l, step=10)
samp <- sample(1:l,sampleSize)
out <- out[samp]
}
else{ # could only happen initially if <=10 trees supplied
updateSliderInput(session, "sampleSize", "Size of random sample:", value=l, min=3, max=l, step=1)
}
}
## fix potential bug with tip labels - they need to match
tipLabelProblem <- FALSE
for (i in 1:length(out)) {
if (!setequal(out[[i]]$tip.label,out[[1]]$tip.label)) {
tipLabelProblem <- TRUE
validate(
need(!tipLabelProblem, "Trees must have identical tip labels for the current version of treespace")
)
}
}
}
validate(
need(!is.null(out), "Waiting for data")
)
## fix potential bug with names - they need to be defined and unique
if(is.null(names(out))) {names(out) <- 1:length(out)}
if(length(unique(names(out)))!=length(out)){
warning("duplicates detected in tree labels - using generic names")
names(out) <- 1:length(out)
}
## return data
# need to pass on the sample so that metaData can be sampled too
if(is.null(samp)) samp <- 1:length(out)
return(list(out=out,samp=samp))
}) # end getData
## GET number of trees
getLengthData <- reactive({
data <- getData()
x <- data$out
validate(
need(!is.null(x), "Loading data set")
)
return(length(x))
})
## GET tree names
getTreeNames <- reactive({
data <- getData()
x <- data$out
validate(
need(!is.null(x), "Loading data set")
)
return(names(x))
})
## GET tip labels
getTipLabels <- reactive({
data <- getData()
x <- data$out
validate(
need(!is.null(x), "Loading data set")
)
return(x[[1]]$tip.label)
})
## GET tree method
getTreemethod <- reactive({
input$treemethod
}) # end getTreemethod
## GET number of axes retained
getNaxes <- reactive({
if(is.null(input$naxes)){
naxes <- 3
}
else {
naxes <- as.numeric(input$naxes)
# when naxes changes we update the options available for the axes
# unfortunately I think they have to reset to their original 1,2,3 values
# but at least they now only do this when naxes changes; they used to also do it for lambda etc.
updateNumericInput(session,"xax", "Indicate the x axis", value=1, min=1, max=naxes)
updateNumericInput(session,"yax", "Indicate the y axis", value=2, min=1, max=naxes)
# (if relevant, update z axis selector too)
dim <- getPlotDim()
if (dim==3){
updateNumericInput(session,"zax", "Indicate the z axis", value=3, min=1, max=naxes)
}
}
return(naxes)
}) # end getNaxes
## GET lambda
getLambda <- reactive({
l <- input$lambda
## the following removes the lambda error messages:
validate(
need(!is.null(l), "Loading data set")
)
return(l)
}) # end getLambda
getTipsToEmphasise <- reactive({
input$whichTips
})
getEmphWeight <- reactive({
input$emphWeight
})
# GET the tree vectors as functions of lambda
getKCtreeVecs <- reactive({
data <- getData()
x <- data$out
validate(
need(!is.null(x), "Loading data set")
)
tips <- getTipsToEmphasise()
weight <- getEmphWeight()
df <- sapply(x, function(i) treeVec(i, return.lambda.function=TRUE, emphasise.tips=tips, emphasise.weight = weight))
})
# GET the tree vectors evaluated at lambda
getKCtreeVecsAtLambda <- reactive({
vectors <- getKCtreeVecs()
l <- getLambda()
validate(
need(!is.null(vectors), "Analysing data")
)
t(sapply(vectors, function(i) i(l)))
})
## GET KC matrix, evaluated at lambda
getKCmatrix <- reactive({
vls <- getKCtreeVecsAtLambda()
as.dist(rdist(vls))
}) # end getKCmatrix
## GET medTrees for all clusters
getMedTreesList <- reactive({
mat <- getKCtreeVecsAtLambda()
groves <- getClusters()
if(!is.null(groves$groups)){ # if clusters have been picked
numGroups <- length(unique(groves$groups))
med <- medTree(mat,groves$groups)
lapply(1:numGroups, function(x) med[[x]]$treenumbers[[1]])
}
else{
medTree(mat)$treenumbers[[1]]
}
})
getMedTree <- reactive({
data <- getData()
x <- data$out
whichClust <- input$selectedMedTree
medList <- getMedTreesList()
if(whichClust=="all"){
x[[medList[[1]]]]
}
else{
x[[medList[[as.numeric(whichClust)]]]]
}
})
getMedTree1 <- reactive({
data <- getData()
x <- data$out
whichClust <- input$selectedMedTree1
medList <- getMedTreesList()
if(whichClust=="all"){
x[[medList[[1]]]]
}
else{
x[[medList[[as.numeric(whichClust)]]]]
}
})
getMedTree2 <- reactive({
data <- getData()
x <- data$out
whichClust <- input$selectedMedTree2
medList <- getMedTreesList()
if(whichClust=="all"){
x[[medList[[1]]]]
}
else{
x[[medList[[as.numeric(whichClust)]]]]
}
})
## GET PCO analysis ##
getPCO <- reactive({
D <- getKCmatrix()
naxes <- getNaxes()
validate(
need(!is.null(D), "Analysing data")
)
validate(
need(!is.null(naxes), "Analysing data")
)
dudi.pco(D,scannf=FALSE,nf=naxes)
}) # end getPCO
## GET ANALYSIS ##
getAnalysis <- reactive({
data <- getData()
x <- data$out
validate(
need(!is.null(x), "Loading data set")
)
naxes <- getNaxes()
TM <- getTreemethod()
## select method used to summarise tree
if(!is.null(TM)){
if(TM %in% c("BHV","KF","RF","wRF","patristic","nNodes","Abouheif","sumDD")){
## run treespace (suppress warnings about rootedness etc.)
res <- suppressWarnings(treespace(x, method=TM, nf=naxes))
}
else if(TM=="metric"){
## don't actually need to call treespace here, to save on recomputation for varying lambda
D <- getKCmatrix()
pco <- getPCO()
res <- list(D=D, pco=pco)
}
}
## return results
return(res)
}) # end getAnalysis
#################################################
### Little "get" functions to support getClusters
#################################################
getNclust <- reactive({
if(!is.null(input$nclust)) {
input$nclust
} else {
2
}
})
getClustmethod <- reactive({
input$clustmethod
})
################
## GET CLUSTERS
################
getClusters <- reactive({
## stop if clusters not required
if(!input$findClusters) return(NULL)
else if(input$clusterType=="meta") return(NULL)
## reset the densiTree plot to accommodate number of clusters available
choices <- getClustChoices()
updateSelectInput(session, "selectedDensiTree", "Choose collection of trees to view in densiTree plot",
choices=choices, selected="")
## reset the median tree choices to accommodate number of clusters available
updateSelectInput(session, "selectedMedTree", "Median tree from:",
choices=choices, selected="all")
updateSelectInput(session, "selectedMedTree1", "Median tree from:",
choices=choices, selected="all")
updateSelectInput(session, "selectedMedTree2", "Median tree from:",
choices=choices, selected="all")
## get dataset
data <- getData()
x <- data$out
validate(
need(!is.null(x), "Loading data set")
)
naxes <- getNaxes()
TM <- getTreemethod()
nclust <- getNclust()
clustmethod <- getClustmethod()
## select method used to summarise tree
if(!is.null(TM)){
if(TM %in% c("BHV","RF","KF","patristic","nNodes","Abouheif","sumDD")){
## run findGroves
res <- findGroves(x, method=TM, nf=naxes, nclust=nclust, clustering=clustmethod)
} else if(TM=="metric"){
res <- findGroves(getAnalysis(), nclust=nclust, clustering=clustmethod)
}
}
## return results
return(res)
}) # end getClusters
## DYNAMIC UI COMPONENTS ##
## SELECTION OF MDS AXES
output$naxes <- renderUI({
if(!is.null(getLengthData())) {
nmax <- getLengthData()
} else {
nmax <- 100
}
sliderInput("naxes", "Number of MDS axes retained:", min=2, max=nmax, value=3, step=1)
})
## VALUE OF LAMBDA FOR METRIC
output$lambda <- renderUI({
## if KC metric has been chosen
TM <- getTreemethod()
if(TM=="metric") {
sliderInput("lambda", "Value of lambda", min=0, max=1, value=0, step=0.01)
} else {
NULL
}
})
## SELECTION OF NUMBER OF CLUSTERS
output$nclust <- renderUI({
if(!is.null(data <- getData())) {
nmax <- length(data$out)
} else {
nmax <- 100
}
nmax <- min(20, nmax)
sliderInput("nclust", "Number of clusters:", min=2, max=nmax, value=2, step=1)
})
## SELECTION OF TIPS
output$whichTips <- renderUI({
# populate selection box with tip choices
allTips <- getTipLabels()
choices <- c("",allTips)
names(choices) <- c("Type here to search tip names",allTips)
selectInput("whichTips", "Select one or more tips to emphasise:",
choices=choices, selected=NULL, selectize=TRUE, multiple=TRUE)
})
## GET METADATA ## for colouring trees by type
getMetaData <- reactive({
out <- NULL
data <- getData()
samp <- data$samp
## data is an input file
if(input$clusterType=="meta" && !is.null(input$metadatafile)){
## need to rename input file
oldName <- input$metadatafile$datapath
extension <- adegenet::.readExt(input$metadatafile$name)
newName <- paste(input$metadatafile$datapath, extension, sep=".")
file.rename(oldName, newName)
if(tolower(extension) %in% c("rdata","rda")){
out <- get(load(newName))
validate(
need(class(out)%in%c("numeric","character","list","factor"), paste0("The class of the input is ", class(out), ". Please upload a single object of class list, numeric, factor or character, whose length is the same as the number of trees."))
)
}
if(tolower(extension) %in% c("csv")){
csvfile <- read.csv(file=newName, header=FALSE)
out <- csvfile[,1]
validate(
need(class(out)%in%c("numeric","character","list","factor"), paste0("The first column of the csv file has been extracted. However, the class of the input is ", class(out), ". Please alter the entries so that it can be read by R as an object of class list, numeric, factor or character, whose length is the same as the number of trees."))
)
}
if(class(out)=="list") {out <- unlist(out)}
l <- getLengthData()
out <- out[samp]
validate(
need(length(out)==l, paste0("The length of the metadata must be the same as the number of trees, which is ", l, ". However, the length of the input is ", length(out)))
)
}
## return metadata
return(out)
}) # end getMetaData
######################################################
### Little "get" functions to support getPlot
######################################################
getPalette <- reactive({
get(input$palette)
})
getLabcol <- reactive({
ifelse(!is.null(input$labcol), input$labcol, "black")
})
getBgcol <- reactive({
ifelse(!is.null(input$bgcol), input$bgcol, "white")
})
getXax <- reactive({
input$xax
})
getYax <- reactive({
input$yax
})
getZax <- reactive({
input$zax
})
getShowlabels <- reactive({
input$showlabels
})
getLabelsize <- reactive({
input$labelsize
})
getPointsize <- reactive({
input$pointsize
})
getPlotFunction <- reactive({
input$graphics
})
##############
## GET plot
##############
## GET whether plot is 2D (default) or 3D
getPlotDim <- reactive({
plotDim <- input$plot3D
if(is.null(plotDim)) {2} # needed during startup
else {return(plotDim)}
})
## GET 2D plot
getPlot <- reactive({
res <- getAnalysis()
pal <- getPalette()
labcol <- getLabcol()
groves <- getClusters()
treeTypes <- getMetaData()
showlabels <- getShowlabels()
pointSize <- getPointsize()
if(!is.null(treeTypes)) {
groups <- treeTypes
cols <- fac2col(1:length(unique(groups)),col.pal=pal)
}
else if (!is.null(groves)) {
groups <- groves$groups
cols <- fac2col(1:length(unique(groups)),col.pal=pal)
}
else {
groups <- NULL
n <- getLengthData()
cols <- rep(labcol, n)
}
## get aesthetics
xax <- getXax()
yax <- getYax()
plotFunction <- getPlotFunction()
if (plotFunction==1) {
transitions <- input$transitions
# labels and tree names
treeNames <- getTreeNames()
if (is.null(groups)) { tooltips <- paste0("Tree ", treeNames) }
else { tooltips <- paste0("Tree ",treeNames,", cluster ",groups) }
treeLabels <- NULL
labelsize <- NULL
if(showlabels==TRUE) {
treeLabels <- getTreeNames()
labelsize <- getLabelsize()
}
pointOpacity <- input$pointopacity
plot <- plotGrovesD3(res$pco, xax=xax, yax=yax,
treeNames=treeLabels, labels_size=labelsize*5,
point_size = pointSize*40, point_opacity = pointOpacity,
groups=groups, colors=cols, col_lab="Cluster",
xlab=paste0("Axis ",xax), ylab=paste0("Axis ",yax),
tooltip_text = tooltips,
transitions=transitions, legend_width=50
)
# later could add:
# other categories of variation e.g. metadata using symbols
}
else { # i.e. plotFunction==2
bgcol <- getBgcol()
scattertype <- input$scattertype
screemds <- input$screemds
optimlabels <- input$optimlabels
labelsize <- getLabelsize()
if(is.null(groves)){
plot <- plotGroves(res$pco, groups=treeTypes, type=scattertype, xax=xax, yax=yax,
scree.posi=screemds, lab.optim=optimlabels,
lab.show=showlabels, lab.cex=labelsize,
lab.col=labcol,
point.cex=pointSize, bg=bgcol, col.pal=pal)
}
else {
## plot with statistically identified groups
plot <- plotGroves(groves, type=scattertype, xax=xax, yax=yax,
scree.posi=screemds, lab.optim=optimlabels,
lab.show=showlabels, lab.cex=labelsize,
lab.col=labcol,
point.cex=pointSize, bg=bgcol, col.pal=pal)
}
}
return(plot)
})
getDistPlot <- reactive({
res <- getAnalysis()
refTree <- input$selectedRefTree
validate(
need(refTree!="", "Select a reference tree")
)
groves <- getClusters()
treeNames <- getTreeNames()
pal <- getPalette()
dists <- as.matrix(res$D)[refTree,]
g1 <- s1d.label(dists, labels=treeNames, poslabel="regular", p1d.horizontal=FALSE, p1d.reverse=TRUE, plot=FALSE)
if(!is.null(groves$groups)){
pal <- getPalette()
nclusts <- getNclust()
ordercols <- fac2col(1:nclusts, col.pal=pal)
g2 <- s1d.boxplot(dists,fac=groves$groups, col=ordercols, p1d.horizontal=FALSE, plot=FALSE)
ADEgS(c(g1, g2), layout = c(1, 2))
}
else{
g1
}
})
getPlotType <- reactive({
input$plotType
})
## TREESPACE IMAGE ##
output$treespacePlot <- renderUI({
type <- getPlotType()
if (type==1){ # i.e. full tree landscape
plotFunction <- getPlotFunction()
if (plotFunction==1) { # i.e. scatterD3
scatterD3Output("scatterplotD3")
}
else { # i.e. adegraphics
plotOutput("scatterplot", height = "800px")
}
}
else{ # i.e. distance from reference tree plot
i <- input$stretch
height <- as.character(paste0(i,"px"))
plotOutput("DistPlot", height = height)
}
})
# repeat treespacePlot for tree viewer tab
output$scatterplotD3TreeTab <- renderScatterD3({
plotFunction <- getPlotFunction() # need to do this or you get an error when switching between plotGroves and plotGrovesD3
if (plotFunction==1) {
withProgress(message = 'Loading plot',
value = 0, {
for (i in 1:15) {
incProgress(1/15)
}
myplot <- getPlot()
myplot
})
}
})
output$treespacePlotTreeTab <- renderUI({
scatterD3Output("scatterplotD3TreeTab")
})
# 3d output
output$treespacePlot3D <- renderRglwidget({
validate(
need(packageVersion("rgl")>='0.96.0',
paste0("You are running version ",packageVersion("rgl")," of the package rgl, which may not contain all the necessary features for 3D plotting (which are based on the old, separate rglwidget package). Please update to the latest version.")
))
plot <- getPlot3d()
plot
rglwidget()
})
output$scatterplotD3 <- renderScatterD3({
plotFunction <- getPlotFunction() # need to do this or you get an error when switching between plotGroves and plotGrovesD3
if (plotFunction==1) {
withProgress(message = 'Loading plot',
value = 0, {
for (i in 1:15) {
incProgress(1/15)
}
myplot <- getPlot()
myplot
})
}
})
output$scatterplot <- renderPlot({
plotFunction <- getPlotFunction() # need to do this or you get an error when switching between plotGroves and plotGrovesD3
if (plotFunction==2) {
withProgress(message = 'Loading plot',
value = 0, {
for (i in 1:15) {
incProgress(1/15)
}
myplot <- getPlot()
myplot
})
}
}, res=120)
output$DistPlot <- renderPlot({
withProgress(message = 'Loading plot',
value = 0, {
for (i in 1:15) {
incProgress(1/15)
}
myplot <- getDistPlot()
plot(myplot)
})
}, res=120)
getPlot3d <- reactive({
res <- getAnalysis()
xax <- getXax()
yax <- getYax()
zax <- getZax()
col <- getLabcol()
# show clusters?
clusts <- getClusters()
treeTypes <- getMetaData()
if (!is.null(clusts)){
pal <- getPalette()
cols3d <- fac2col(clusts$groups,col.pal=pal)
}
else if (!is.null(treeTypes)) {
pal <- getPalette()
cols3d <- fac2col(treeTypes,col.pal=pal)
}
else{cols3d <- col}
rgl::plot3d(res$pco$li[,xax],res$pco$li[,yax],res$pco$li[,zax],
type="s", size=getPointsize(),
xlab="",ylab="",zlab="",
col=cols3d, add=FALSE)
})
## make Shepard plot
getShep <- reactive({
res <- getAnalysis()
dim <- getPlotDim()
xax <- getXax()
yax <- getYax()
if (dim==2) { shep <- Shepard(res$D,as.matrix(res$pco$li[,xax],res$pco$li[,yax])) }
else {
zax <- getZax()
shep <- Shepard(res$D,as.matrix(res$pco$li[,xax],res$pco$li[,yax],res$pco$li[,zax]))
}
})
output$shepPlot <- renderPlot({
withProgress(message = 'Loading Shepard plot',
value = 0, {
for (i in 1:15) {
incProgress(1/15)
}
shep <- getShep()
labcol <- getLabcol()
plot(shep, pch=19, cex=0.5, col=labcol, xlab="Distance in tree space", ylab="MDS distance")
})
}, res=120)
output$shep <- renderUI({
plotOutput("shepPlot", width="800px", height="800px")
})
## make screeplot
output$screePlot <- renderPlot({
res <- getAnalysis()
labcol <- getLabcol()
barplot(res$pco$eig, col=labcol)
}, res=120)
output$scree <- renderUI({
plotOutput("screePlot")
})
# get tree and aesthetics for plotting tree
getTreeChoice <- reactive({
input$treeChoice
})
getTreeChoice1 <- reactive({
input$treeChoice1
})
getTreeChoice2 <- reactive({
input$treeChoice2
})
getTree <- reactive({
data <- getData()
x <- data$out
validate(
need(!is.null(x), "Loading data set")
)
treechoice <- getTreeChoice()
if(treechoice=="med"){
tre <- getMedTree()
}
else{
g <- input$selectedGenTree
validate(
need(g!="", "Select tree to view")
)
treeNum <- as.numeric(g)
tre <- x[[treeNum]]
}
# return tree
if(!is.null(tre)){
if(input$ladderize){
tre <- ladderize(tre)
}
return(tre)
}
else{
NULL
}
})
getTree1 <- reactive({
data <- getData()
x <- data$out
validate(
need(!is.null(x), "Loading data set")
)
treechoice <- getTreeChoice1()
if(treechoice=="med"){
tre <- getMedTree1()
}
else{
g <- input$selectedGenTree1
validate(
need(g!="", "Select first tree to compare")
)
treeNum <- as.numeric(g)
tre <- x[[treeNum]]
}
# return tree
if(!is.null(tre)){
if(input$ladderize){
tre <- ladderize(tre)
}
return(tre)
}
else{
NULL
}
})
getTree2 <- reactive({
data <- getData()
x <- data$out
validate(
need(!is.null(x), "Loading data set")
)
treechoice <- getTreeChoice2()
if(treechoice=="med"){
tre <- getMedTree2()
}
else{
g <- input$selectedGenTree2
validate(
need(g!="", "Select second tree to compare")
)
treeNum <- as.numeric(g)
tre <- x[[treeNum]]
}
# return tree
if(!is.null(tre)){
if(input$ladderize){
tre <- ladderize(tre)
}
return(tre)
}
else{
NULL
}
})
getTipDiff <- reactive({
tr1 <- getTree1()
tr2 <- getTree2()
tipDiff(tr1,tr2)
})
getTipDiffTable <- reactive({
tipDiff <- getTipDiff()
# data frame of the tips with differences:
if (!is.null(tipDiff)) {
out <- tipDiff[which(tipDiff[,2]!=0),]
rownames(out) <- NULL
colnames(out) <- c("Tips with ancestral differences","No. of differences")
return(out)
}
else {NULL}
})
## PHYLOGENY ##
output$tree <- renderPlot({
tre <- getTree()
if(!is.null(tre)){
## plot tree ##
par(mar=rep(2,4), xpd=TRUE)
plot(tre, type=input$treetype,
use.edge.length=as.logical(input$edgelengths),
show.tip.lab=input$showtiplabels,
tip.color=input$tiplabelcolour,
font=as.numeric(input$tiplabelfont),
cex=input$tiplabelsize,
direction=input$treedirection,
edge.width=input$edgewidth,
edge.color=input$edgecolor
)
}
})
output$treeDiff <- renderPlot({
tr1 <- getTree1()
tr2 <- getTree2()
tipDiff <- getTipDiff()
CM <- c("ramp","palette")[[as.numeric(input$colourMethod)]]
tipPal <- c(funky, spectral, seasun, lightseasun, deepseasun,
rainbow, azur, wasp)[[as.numeric(input$tipPalette)]]
if(!is.null(tr1)&&!is.null(tr2)){
## plot tree comparison ##
#par(mar=rep(2,4), xpd=TRUE)
plotTreeDiff(tr1,tr2,
tipDiff = tipDiff,
baseCol=input$basetiplabelcolour,
col1=input$minortiplabelcolour,
col2=input$majortiplabelcolour,
colourMethod=CM,
palette=tipPal,
type=input$treetype,
use.edge.length=as.logical(input$edgelengths),
show.tip.lab=input$showtiplabels,
font=as.numeric(input$tiplabelfont),
cex=input$tiplabelsize,
treesFacing=input$treesFacing,
edge.width=input$edgewidth,
edge.color=input$edgecolor
)
}
})
output$tipDiffTable <- renderTable({
table <- getTipDiffTable()
})
## DENSITREE
# The slider bar is always at least 2 even when clusters haven't
# been requested, so we can't just use getNclust.
getNclustForDensiTree <- reactive({
if(input$clusterType=="meta"){NULL}
else{input$nclust}
})
getClustChoices <- reactive({
nclust <- getNclustForDensiTree()
if(is.null(nclust)){
choices <- c("","all")
names(choices) <- c("Choose one","All trees")
}
else{
choices <- c("",1:nclust,"all")
names(choices) <- c("Choose one",paste0("Cluster ",1:nclust),"All trees")
}
return(choices)
})
getDensiTree <- reactive({
clusterNo <- input$selectedDensiTree
if(clusterNo==""){
NULL
}
else if(clusterNo=="all"){
data <- getData()
x <- data$out
medList <- getMedTreesList()
med <- x[[medList[[1]]]]
return(list(trees=x,con=med))
}
else{
data <- getData()
x <- data$out
clusts <- getClusters()
clustTrees <- x[which(clusts$groups==as.numeric(clusterNo))]
medList <- getMedTreesList()
med <- x[[medList[[as.numeric(clusterNo)]]]]
return(list(trees=clustTrees, con=med))
}
})
output$densiTree <- renderPlot({
if(is.null(rvs$showDensiTree)) {NULL}
else{
withProgress(message = 'Loading densiTree plot',
detail = 'Note: the final stage of this process may take a while for large sets of trees',
value = 0, {
for (i in 1:30) {
incProgress(1/30)
}
clustTrees <- getDensiTree()
densiTree(clustTrees$trees, col=4, consensus=clustTrees$con, alpha=input$alpha, scaleX=input$scaleX)
})
}
})
## EXPORT TREES ##
output$exporttrees <- downloadHandler(
filename = function() { paste(getDataSet(), '.nex', sep='') },
content = function(file) {
if(!require(ape)) stop("ape is required to save trees into nexus file")
data <- getData()
x <- data$out
if(!is.null(x) && inherits(x, "multiPhylo")) ape::write.nexus(x, file=file)
})
## EXPORT ANALYSIS TO CSV ##
output$exportrestocsv <- downloadHandler(
filename = function() { paste(getDataSet(), "-analysis", '.csv', sep='') },
content = function(file) {
data <- getData()
x <- data$out
res <- getClusters()
if(!is.null(res)){
tab <- cbind.data.frame(res$groups, res$treespace$pco$li)
names(tab) <- c("cluster", paste("PC", 1:ncol(res$treespace$pco$li), sep="."))
row.names(tab) <- names(x)
} else{
res <- getAnalysis()
tab <- res$pco$li
names(tab) <- paste("PC", 1:ncol(tab), sep=".")
row.names(tab) <- names(x)
}
if(!is.null(res)) write.csv(tab, file=file)
})
## EXPORT ANALYSIS TO RDATA ##
output$exportrestordata <- downloadHandler(
filename = function() { paste(getDataSet(), "-analysis", '.RData', sep='') },
content = function(file) {
data <- getData()
trees <- data$out
analysis <- getClusters()
if(is.null(analysis)) analysis <- getAnalysis()
if(!is.null(analysis)) {
save(trees, analysis, file=file)
}
})
## EXPORT 2D plotGroves MDS PLOT AS png ##
output$downloadMDS <- downloadHandler(
filename = function() {
paste0(getDataSet(),"scape2D.png")
},
content = function(file) {
myplot <- getPlot()
png(file=file, width = 10, height = 10, units = 'in', res = 500)
plot(myplot)
dev.off()
contentType = 'image/png'
}
)
## EXPORT 2D plotGrovesD3 PLOT AS html ##
output$downloadMDS2Dhtml <- downloadHandler(
filename = function() {
paste0(getDataSet(),"scape2D.html")
},
content = function(file) {
htmlwidgets::saveWidget(
getPlot(),
file=file,
selfcontained = TRUE)
},
contentType = 'html'
)
## EXPORT 3D MDS PLOT AS html ##
output$downloadMDS3Dhtml <- downloadHandler(
filename = function() { paste0(getDataSet(),"scape3D.html") },
content = function(file) {
options(rgl.useNULL=FALSE)
myplot <- getPlot3d()
myplot
rglwidget()
rgl::writeWebGL(dir=getwd(), filename=file, snapshot=TRUE, width = 500, reuse=TRUE)
},
contentType = 'html'
)
## EXPORT SHEPARD PLOT AS PNG ##
output$downloadShep <- downloadHandler(
filename = function() { paste0(getDataSet(),"Shepard.png") },
content = function(file) {
shep <- getShep()
labcol <- getLabcol()
png(file=file, width = 10, height = 10, units = 'in', res = 500)
plot(shep, pch=19, cex=0.5, col=labcol, xlab="Distance in tree space", ylab="Distance on MDS plot")
dev.off()
},
contentType = 'image/png'
)
## EXPORT SCREEPLOT AS PNG ##
output$downloadScree <- downloadHandler(
filename = function() { paste0(getDataSet(),"screeplot.png") },
content = function(file) {
res <- getAnalysis()
labcol <- getLabcol()
png(file=file, width = 5, height = 3, units = 'in', res = 500)
barplot(res$pco$eig, col=labcol)
dev.off()
},
contentType = 'image/png'
)
## EXPORT TREE PLOT AS PNG ##
output$downloadTree <- downloadHandler(
filename = function() { paste0(getDataSet(),"SingleTree.png") },
content = function(file) {
tre <- getTree()
png(file=file)
plot(tre, type=input$treetype,
show.tip.lab=input$showtiplabels, font=as.numeric(input$tiplabelfont), cex=input$tiplabelsize,
direction=input$treedirection,
edge.width=input$edgewidth)
dev.off()
contentType = 'image/png'
}
)
## EXPORT TREE COMPARISON PLOT AS PNG ##
output$downloadTreeDiff <- downloadHandler(
filename = function() { paste0(getDataSet(),"TreeDiff.png") },
content = function(file) {
tr1 <- getTree1()
tr2 <- getTree2()
png(file=file)
plotTreeDiff(tr1,tr2,
tipDiff = tipDiff,
baseCol=input$basetiplabelcolour,
col1=input$minortiplabelcolour,
col2=input$majortiplabelcolour,
colourMethod=CM,
palette=tipPal,
type=input$treetype,
use.edge.length=as.logical(input$edgelengths),
show.tip.lab=input$showtiplabels,
font=as.numeric(input$tiplabelfont),
cex=input$tiplabelsize,
treesFacing = input$treesFacing,
edge.width=input$edgewidth,
edge.color=input$edgecolor
)
dev.off()
contentType = 'image/png'
}
)
## EXPORT TIP DIFF TABLE ##
output$downloadTipDiffTable <- downloadHandler(
filename = function() { paste0(getDataSet(),"TipDiffTable.csv")},
content = function(file) {
table <- getTipDiffTable()
write.csv(table, file)
}
)
## EXPORT DENSITREE PLOT AS PNG ##
output$downloadDensiTree <- downloadHandler(
filename = function() { paste(getDataSet(), 'DensiTreeCluster',input$selectedDensiTree,'.png', sep='') },
content = function(file) {
clustTrees <- getDensiTree()
png(file=file)
densiTree(clustTrees, col=4, alpha=input$alpha, scaleX=input$scaleX)
dev.off()
contentType = 'image/png'
}
)
output$selectedGenTree <- renderUI({
numTrees <- getLengthData()
treeNames <- getTreeNames()
choices <- c("",1:numTrees)
names(choices) <- c("Choose one",treeNames)
selectInput("selectedGenTree", "Choose individual tree",
choices=choices, selected="")
})
output$selectedGenTree1 <- renderUI({
numTrees <- getLengthData()
treeNames <- getTreeNames()
choices <- c("",1:numTrees)
names(choices) <- c("Choose one",treeNames)
selectInput("selectedGenTree1", "Choose individual tree",
choices=choices, selected="")
})
output$selectedGenTree2 <- renderUI({
numTrees <- getLengthData()
treeNames <- getTreeNames()
choices <- c("",1:numTrees)
names(choices) <- c("Choose one",treeNames)
selectInput("selectedGenTree2", "Choose individual tree",
choices=choices, selected="")
})
output$selectedRefTree <- renderUI({
numTrees <- getLengthData()
treeNames <- getTreeNames()
choices <- c("",1:numTrees)
names(choices) <- c("Choose one",treeNames)
selectInput("selectedRefTree", "Select a reference tree",
choices=choices, selected="")
})
## RENDER SYSTEM INFO ##
output$systeminfo <- .render.server.info()
}) # end shinyServer
treespace/inst/shiny/www/ 0000755 0001762 0000144 00000000000 13164413033 015156 5 ustar ligges users treespace/inst/shiny/www/img/ 0000755 0001762 0000144 00000000000 13164413033 015732 5 ustar ligges users treespace/inst/shiny/www/img/logo.png 0000644 0001762 0000144 00000156257 13164413033 017420 0 ustar ligges users ‰PNG
IHDR
˜ñhO sBIT|dˆ pHYs .# .#x¥?v tEXtSoftware www.inkscape.org›î< IDATxœìw˜]eµ‡ß™IIHè-´5Ò›‚AQi‚å¢(vïõÚ¯¨¨`Á^±wPÀ
R¥éz>H€@H©„ôÌ$™™ûÇoí9ûì³Ï™™$¤±Þç™gfvùö·÷>™¬õßZ«©««‹ ‚ ‚ ‚z4¯í AAA°nNCAA
§!‚ ‚ ‚†„ÓAAACÂi‚ ‚ ‚ !á4AAAÐp‚ ‚ ‚ hH8
AAA4$œ† ‚ ‚ NCAA
§!‚ ‚ ‚†„ÓAAACÂi‚ ‚ ‚ !á4AAAÐp‚ ‚ ‚ hH8
AAA4$œ† ‚ ‚ NCAA
§!‚ ‚ ‚†„ÓAAACúí k3666FáÀ`` Ðß¿÷óŸû!'³è:üû
`™µmÀR`°Ð¿æ sR¢mÍÜ]AA°:iêêêZÛs^FÌlì순ƒkqJ+Sñ"ð40˜‘íkqNAAAÂiØ@0c#`°+°0’•wºüMèÊmÏ$mMþ•ÿ¹+·¯t ‹#ñDJÌ]ɱ‚ ‚ ‚ÕH8
ë)fôCÎÁ«éÙAèB¢yÀ4$Zè¿/¥"-j–¥ÄJ}0ÌhAr¦þHê´-°50ØI úÑ;ç¢E$&÷¦Ä¬•™SAA°j„Ó°aÆÀÁ@+0Œrûþ/ÏÏ Õû9)ѹ†¦Ú3š‘LjÿÚØ9œ‰Nt_÷¤Ä‚—yªAAá4¬Ó˜1 EöF+õ-%‡µ¡ÈÁ“(G`fJ,_c“\ä¢'‡Û{8e90¸É™Ö §(‚ ‚`C#œ†uŒœ£ðZ`cjWÞ;ÙÀƒÀ})±xÍÎpÍaÆ ä0Œœ¦F%‚»PT冔xf
L/‚ ‚àC8
ëfl
¼ØZG¡×õϤDÇj¾ö $Úô‘ÈiÉršýçNÿÊæ5˜r$fûïó€/Ã<7EQˆ}Q¹Øz¬ ®I‰…«sAA¯DÂiX‹˜Ñxp0¨°{1íþJ' ›Ñ„ŒÿMs_#S°2¾û¯ìø
èB‰ÌK€È‘˜ÌBÎÅKȱX)I‘CÐs;ÒàÐÅÀÀ«Û‰ ‚ ‚ x¥NÃZÀŒÐŠ~>ª°¸¸%%–¬Ä¸YÙÕ-üksV®ó÷ª”OíË53€ À³Àô”XÑ—A̼ Øò¼Œ)ÀU)1y¥fAAð
%œ†5„—"=ŒWö§W¦ÄÓ}ss`O`w䀣½aÕÁg÷£È`Tòt°*Ñú$°Gd6Š(Œ^‰k×c z&Ï"gbZo"UÙ9›õ0þ¥)ñèj˜kAÁO8
/3fG¹
T¯Üw¡dæ«SbQ/Çê‡z2Šrz++ZêÇö+Ùw ê½ÊU˜‚*e<å×ømJêQcï«ç»Ðû&nyV ²¤Y¢(7Z|
x¿]¥Èa˜ês ¼¸$%ÚÍ88ªpÎ5À±è~ÿ|¨pýNjeSã‘߈.ày”þXod\fì¼IµÊX\‘÷õ4VAÁ+‘pV3žÜ|<*šgðÏ”x®—ãl¼Ñƒ}óåÀ(o!Oðu´Ú¿inû£Àu¨2ÒѨ‘Úlß>É.GQ†c)¯H´ ø.rVÆå»E›q,pDÉy³üÜ¿!cûÂþÿ ˆIÞqXFßœ"PÕ¦û|^óhÆÆÀÉÀ”çk,G‘Ÿ»ú8‡ ‚ ‚
špVxp$Õ†ðsÀ_RâÅ^Œ1 õ%8„ZÇ ä”å-,GÑ€²¾]Àxàï)ÑV¸^´âÿ)TM©åŒCyÀeÀãÀç€æ”8«0Æ'Pâõ`W¿~2¾ï5ãxÔsbM0I¾îjä@¸ÌëX䔕%‰w ÿN‰ÿ¼,³‚ ‚ Xϧa5`Æ!ÀqTëög¤Äœ^œ?88ˆ¾¯´÷–àò”¸§pí¥h§Ä¹¾ýH”Püu`kà=ÀŠ”øBáü/C‘sñ”8}AJ¼dÆÞ(ÊPäù¨W)_¹i)ðCmù½OöžÜØSdÇšCëÌ¥9|©—ׂ ‚ Ø §a0c,ðn``nóRà┘؋ó·B•²úžX‚"™Œ¨¸
÷ýÇM ¶@eWó¼ œŸÏ§0ãtTu¨3‹$˜q4°oJ|ÇŒ× 'úá×7e%3¾Eeµ~ðÓ”X`Æ(‚Q¼¯ÙÀ¯R¿ì5H–5ʇʩEÎÀnuÎ+cpðh½wœNCÑ•2f H‰—úpÝ ‚ ‚
†U©hóŠÅŒÍ€3¨–u Ä·÷pn°’2Õ«6”±•?}µÿ>—êdÞN”+P¬´,%þbÆ.(Éù)Ô m+$%:¸3wüÀ«pßç¸50ØŒ· ¹TÆ”éÿ=s
þ•Ký÷7Që0tv¢qïˆÃ¨Î¯È'GïÚà¼2Fï N4ãàžb—hw&.1ã2à¿Pây~î£Ï›q;zÇÑ$.‚ ‚Wá4ô_‘~3ÒÂgFe2˜ÿÞȘ4c Š*ìOï%6ý¨8 C>»æý¨—ÁÔÏ`$Z‰o6õêMYiÒ±¹1ºP´¡´ž,|&•Å¡¹ó:|N;äN_Šébå¡í¿_ ÌH‰Í8¹Á=CyBöK(É»QDfQs¢|ׯ3ã.-©ª¼ä9¿ógð”8žçµÀf\œz¸‡ ‚ ‚
†'õ¯fô`XnóÀoRbqƒó†¡Š=»±r™ó,î@rÁhÅ~’ÞtzgäÏø±¿÷}Ÿª3Öó)ñãÜ<¦¢•üý
Çv ç¥ÄB3þgûy›¦Ä¼üÁfl|´pþR¢«d_#Ú»Prù€£ˆI=B›/l¿å[äYÜÜ–ËË3c;ä<-Ù=øco{lAA¬ÏD¤¡ä’‚3:³ðLƒs¶DQ‰FýzC>)x2°#ZñÎK’^cƯRb–Ë}ßVÀ´ãneÆÁYbtJ\éóÞ·pÜTh¡Ë–FC¥Tæ0x~ÆtïÜ\cž;CPõÞ293Sb†Y]¡GwSë4_rl$µ:ÂŒë€;‹]§=‰ú\3^çÇæ¾m³Í¸(%ëõAA¬‡„ÓÐ 3ŸD}2žFCiˆÆŒ1À©T¤D«Ê2àFdˆïLy´b{T½é
Trô $[ZLµÓQä$3¦Äm¹mÍ(‚r=2ÂïÏÉx²ærOç1ã`à$à,—aíÛ½øû!'j *C;E
ú¡ÊMÍ
æy«Í4Ž2€JÖ9J$MSq¤ÿJ‰G‹¤ÄÍfÜ‹òCò‰åÍÀ»Ìxøs½ˆEAÁúN8
u()Ú‰ª"Õ•~ü$Ù‡ÞUBê--Râ‡n8o
læû–ù¼SÉSøÒõòÕýyÈéÉtý³|é83ÚRâ^ß¾)J~'r@òd+øÝ+ëfE÷=ǯw*•œ ¨rÑG©Èº:QwéöüÀÅ89<ÿD%kOñóEL#y×|àf—i]òòåkŸ@Q“¢ô*c#àt3f¡÷\ÌûXüØ#1§æ²;ð3~–ÓÌ1‚ ‚`½dU5öf4™ñAª†9ÀWË?þà‹(PÏa˜üøÊI˜åÑŠö7ãmÈ!‘»Æ`däofÆ^)Ñ‘ —ú1ãüû}P•{0
U UÊ>üû Teé³flâÛ¶DÎÁäìÞ!ç3«µrbþ€´?HuH3pTñ=r“Íïä@´ã|¿ 9OW†˜ƒ$WYää*ÎÍÓ)ñ䈀äUK(gðq3Þæ‘¦â<Dåbçv
>aV%c‚ ‚ Ø ˆDèfGr¤¼±xkJ\Sçø-Óé¹tjÆ<à^$£™áÐJu+2XWÕ‘{ ¸,%UNòîÿ£âhÜ\‡Ê¨;ïï)q†lãRâofœ¢3ÜÉ89 À—Sb¹ ø8rhòdÕº€_dÎG†W§ÊºSwú8Éd?fÈÝ×;©–Aet7¤ÄMž´½-*;ø„?‡R"™±’’Õ{ËQÙûËvz9ÚCKvM~–Í5‚ ‚`}'"
Ž gQq–?.s<ºp2Œ{ë0€ŒèccòO¼í@ïá"àÀùhÕ~6ô˜ø[ä¯(WàcÞK‚”xªŒÞ'RbqJ\\œ»Æëüûã%×Ýݿӆ&àÓT"ù
DO
NE‡¡Ãïm2ÜßçÕ‰0c3ŽA«õ"ç✔øS!O`+3Þíyõòf$q9“'‘D*sœÞiÆ)ñ,ð|q@ÉÒ§šñY¯LUEJ\üjrÆ _v‡-‚ ‚`½çï4¸p:ZqÎŒÊih弯 4cSà‘ñ¿²¹ËÄaX€d?)15%®L‰ïzwæo#©Ñœ^Œ{*úði³î>WP‘ã왜?E2 MÍèç«ãÆäÇg}(6¡’WцJ—fìHy‰ÒNï¨ü3ä”þÛŒ3€Ï#ÉÒP4¢ÌàÞÓÏíH‰ gߣÐw˜äßÏI‰Ÿ£ÈI¾kw`oFözb$ð3ÞêÑnÜñ8—ÚìÀÿ™ñª^ŒAA°NóŠ–'¹ø1¤ÕÉf®M©ÊοÒÛ¯Jù2àçY¢¨È“"c³€OA²š¹~î>h}s?¶9.yç¯Óïc ðï””Óà«Þ§
HO 7¦ÄTß7ø pµËvöA]”3V¤Ä
Ïb`Às)1Ë·í’Ozχ×î{\JüÍÛ9i#)w¼:ïz”¤.fŒðgµ9q‡äžÅ5)q«¯FÎÀèdìÐó}/r –S‰€4û¶~þ½ÊI@Mæ~–RwîG~>ÇQ[î” }m£{ ‚ ‚ X—yÅ:
n¬žÊªx'ð+_9.;x9ÎÊ0ÉŽD†è¨Ûóô±è nqIÑ*aÆþÈyhƧą¾}#`¿”¸Íµþɶ %¾îÇí œLÌK·¼Ôì'PÎÆ•¨zѾ{)ðMyÁ#xçå=P‡í‘ÈPï .ÏúGø1™S×½¯‘(B%hw¿E›÷¢(È
èYçó9þTì©àÎÏÈq˜ž9@¹ý›#GË€íPòùrTvwrÉóÝx;µïô Ôî•ù.‚ ‚õšW¤Óàòç©4Hë@+ÛsKމôðe’›ztѪôxÔ—`ê¶|rú"
ëD‘ûpN]<²ð~d|ÿ9«
eF³—,ˆ¤BS±ÀÔ”8ßù(ªÖŠdÜâÛ?N¥‡ÁB”l}0*{
’W½Ûïå[%]¤›Ð3^ì¥[7E‚]iü¬:PC·›Rb±;#\è,*¹5†¾Î.Œß†"·#gáZˆÊºî€ä_ „ó»‹rÇêÃÔ:³ï›ÈAA¬ë¼âœ3¶@‰È™¡¸øž×á/»7’éô%wa.ZQžác쀺ïLßdMóQïÀ伡éÆî¿Ö\±Ø°· Ã|)êÅ0
Efî õ,ØÒz)ì°r¬I‰‹Ü™øZî°™)ñ}ŸÏ—(N‹Qç}nËQ9Ô½‘AÿLJÝ9˜Ñ5;¸Îxyþ™5Ÿ3c£”Xä?ŠúG¬@NÀeÅækfœé÷¸*<€*OU9¡øµò¦EÀy)±b¯AA°ÆxE5w3c´Âž18¿XÓˉžˆ×¾Ð\lcÆÑ*}ÿƧ 2lg¡ÐÊ~VZtà½f\ŸSò¢l•½¬ìçP´â¾ð3H‰¿f;]&3®ä¼Œ ÐÄ›%P8&{n£¨øYYÕŒ)Hê”Ï™<èU(crv †’–{óÌ@+÷š1IŸ–ßÍÍù»)1»ìDÏ?(:@;Êém$h?`3~‘wJRâE3¾†äQùNÖç˜ñÌÁ ‚ ‚ X×yÅD¼¤ê©¹MO£žÅâ¡()xK^:Q¿†çP$a207¯uwiÎ(ñ9«"Ôªl^EðuÔ›ap'ðx=©Œ'‰5fûeJ<ã+óáŽNJL2ã äÈLDMݾŒå¬œlæP,@òœ¥%×ë)ªóGäÈEQ•ƒ¨.wûê¿P¬¤TŠï@Ï7Ï=)q©GT>ÝÕ§zËÀJ:]÷>G%ÿ"£®$.‚ ‚`]ãá4*è Õ«î¹ã¶FÃàÕxùEH"49*³ë%Ú±;pï…ÀŠR7ŸëÿQ)S›Ñ…‡Þ”Ó
‚ ‚ XklðNƒ‡Çå6ÝžW–·ðžÕtÙçQï‚§3½}ƒùõCÕCr"ó3°d__YN¹ôg
*#Zóa0c”xÜ5úŸCNPdð~3%–z?ˆ¡Õó%ÈØ8%.6cã”X¸æÞgÌh*DpšP¯‡Cc–9tÏ¡êVÏgΓ;1Û Dî]PI–ß(×bÊ‘)KôþJ>ÏÓ…¢/³‚ ‚ XGÙ 3Þ€ä87–•-uyÍɬ|³¶ŒùÀEY…3£Õåa(i¸[ŠâFé1h¥»˜,[$ÓÊ—ü3Ü(`!2ä@ü2jÊ‘æ1c_TJ4Ïõ)q£Kº¾’Û> U*Z+U‚¼Ã (ZЄ™™À¶4Žt¢<‰‰Àý)1³0îPÔµ»ø¬—Qíðu Ç¡ªÏ„;Ÿ@Hž.à;=õ¥‚ ‚ X[l°NCI„á?)qUÉq¯E’ U¡¸EéíGSm >šökî
üÞiÙ¹
åQì[2þDà"¤Á?
9!}á`dD7º‡‰À_ëT’‹’ÈóŽU'ð¥”XnÆ'‘1|7ê³PÌiA÷·•ߖгӉdAP?ƒg
‚ÍP)ÖöÜï'¡¾ }N]¨ÄÍØ8½Ï¥‹QiØìšM(Ïa'ß?9aO¡HÅiT;dÀORbzq`3þE0òt¢ÈÍüUœwAÁjgƒt¼sóÛr›º»Ž;
ö¯
+PE -¨Ÿ<ý02Ü"íÿÎ%ÇÌGR«3Æ#ÀÅÞÃ`ê<ÜJ¹¤©ÈrTöôCôœ¯qv±šT†GNÞŒÌyøzJ,0c°mJ‡ò–ÿòŸëÅœŸG‘ŠùïB%[»/Š$ѳ'؃šà]—ÓJ"\¨J×¤Â¹Í¨ÞÆ…a;€¯–U˜
‚ ‚ X[lPNƒÛÿMÅa˜œ?/9îxàµ
†šI¥ëïÊ2¸0%fxó³³è9*0 Ž÷CÚúåT¢WR‘QMDÉÆ‹ÌØ„Š\gõs3¾Šr7Zý÷ùÀ¿©ÎU¨÷Ì¢RªGQSQÄ¡^žÈÔ?b?T±iê‰1Ý÷‡žžx&%~Y{sjJt”\»¹N5¨ÀоæZøû;X˜·û¶¢sÚÜ\†JÇîéÛ³&n¦Ä„¸ƒQeªb¦øZ½ˆOAÁšfƒq\Âò™Ü¦™ÀK´õGPY%¯G=¯‚×c)ê>üpẙ$•ÉòvEzöPiÒ}PÕžÞ$ew Ê;Ý‘OÖÝiïwDÒœìº?@ÎÈGPNA¢
gøyßN‰efœ„$I?.9vd<ã÷÷›\‰Ö£×÷ῼ ¸¯Ø¬ÍŒíP4¦hCycQÎÁsÀî(²ÑBµ¿9emÈHoGy‹Prùd”#ÑeÆ{Pè®”ø—ç7|œr9Ú4Tjö㨧Åtä,n\›·æ?‚J·ì<Sªê¾AA°ÖØ :B›±1ðÉܦ…ÀK†½éÙa€•sÚëaY³’íÛ²í/ú×cž Ü™“ÖÜ醿¡o[Sݸ•a