Nothing
library("methods", exclude = c("removeClass", "show"))
library("shiny", quietly = TRUE)
if (!requireNamespace("shinyjs", quietly = TRUE)) {
install.packages("shinyjs")
install.packages("colourpicker") # Necessarily absent, as imports shinyjs
}
library("shinyjs", exclude = c("colourInput", "colourPicker",
"updateColourInput", "runExample"))
if (!requireNamespace("colourpicker", quietly = TRUE)) {
install.packages("colourpicker")
}
library("colourpicker", exclude = c("runExample"))
if (!requireNamespace("Ternary", quietly = TRUE)) {
install.packages("Ternary")
}
library("Ternary")
palettes <- list("#91aaa7",
c("#969660", "#c3dfca"),
c("#be83ae", "#2ea7af", "#fbcdcf"),
c("#72c5a9", "#b7c5ff", "#dbdabb", "#a28bac"),
c("#59c4c0", "#ea9a9a", "#7998a6", "#e9d7a9", "#9c9379"),
c("#e8b889", "#67c6eb", "#e5d5c2", "#938fba", "#64b69a", "#779c7b"),
c("#c4808f", "#5ba08f", "#f0a693", "#ccd7fe", "#cdb87e", "#c6aae2", "#d2dad8"),
c("#d0847f", "#63a5d7", "#d7b981", "#5a9bbb", "#9bb67e", "#dea6d5", "#91967e", "#ca7f96"),
c("#8b93a8", "#ccb97e", "#8e9dd7", "#57a384", "#dbb1e7", "#2da7af", "#d68986", "#75d2f9", "#e4d1f0"),
c("#dfcf92", "#40b3cb", "#b88a61", "#ecb2e0", "#d6dbbc", "#a28bae", "#edcfeb", "#7498ab", "#b187a0", "#8f939c"),
c("#a98f70", "#7be5e2", "#d295c0", "#9ae2bd", "#d3b7f1", "#eca88d", "#8993cd", "#ffc7bb", "#8695a8", "#b3e1df", "#b6878a"),
c("#eaa9d3", "#7ac09b", "#fdaca8", "#8ce7e4", "#eed69b", "#70a4d9", "#e8d6ba", "#589bbb", "#959672", "#d0dbd1", "#9b9282", "#d9d9c6"),
c("#7498ab", "#e5bd8a", "#7ed8ff", "#de8f8e", "#46bac6", "#ffc0d3", "#57ae96", "#f7cddd", "#50a098", "#b58a6d", "#add49d", "#a18da1", "#cedad9"),
c("#8097a4", "#d0dea9", "#a78cc3", "#aee4bf", "#bb82a8", "#5dc9c6", "#b88690", "#26a3b9", "#ad8e6f", "#a4e2ef", "#869a65", "#efcfdd", "#60a089", "#9e927b"),
c("#b9aae5", "#bbd69c", "#e2adde", "#77a777", "#f8abc8", "#8ee7ce", "#f2a1a5", "#81bdf1", "#f2bb91", "#b8dcfe", "#aeb276", "#f2cdef", "#e8d6b2", "#8d92b0", "#b7878d"),
c("#c3d79b", "#b28cc0", "#64a985", "#e3a7d4", "#2ea2aa", "#e69892", "#85c6f9", "#fbd1a0", "#7696be", "#89996c", "#ddcdff", "#719d89", "#f5cde6", "#b6e0da", "#e8d4cd", "#b5ddfa"),
c("#a98d83", "#84e1ff", "#bb8964", "#46b1d1", "#ffbfa5", "#6199c0", "#bbcb8f", "#bf82ab", "#85ddc4", "#eea0ba", "#c1d8ff", "#c3818b", "#c5c6ff", "#999388", "#e8cbff", "#ffb5b6", "#d2dad7"),
c("#faccde", "#60a987", "#c6abe4", "#6f9e77", "#c48093", "#a5e5d3", "#cc8f6f", "#499fae", "#d9dca6", "#7796b8", "#bee1ba", "#b4daff", "#919583", "#e2d3e9", "#47a19b", "#ebd4bc", "#7c9993", "#a9e3e0"),
c("#739e6e", "#ffbfd9", "#43b6bb", "#e8ad88", "#5e9bce", "#c2af75", "#a8e0fe", "#fad0a8", "#679e8d", "#ffc7b1", "#abe5c0", "#ac8d78", "#c5dddc", "#a48f84", "#cadfb0", "#899694", "#fdcdc1", "#d1dad5", "#dfd8c4"),
c("#6e9c93", "#ffb4b3", "#7ec6a2", "#eeccfe", "#cddb9d", "#8a90c5", "#dcb983", "#77bff0", "#f0ab92", "#90ddff", "#f1d3a9", "#b5c2fe", "#c1e1b7", "#7596ba", "#bce1c4", "#a88c96", "#5a9daf", "#b18b80", "#d4d6f3", "#949577"),
c("#e7d6bb", "#749ed5", "#f9d29d", "#67b3e2", "#d09773", "#65ccec", "#d38585", "#7fe8ef", "#cf8190", "#94e8cd", "#ae8cc1", "#b3cf95", "#cbc0fc", "#94a66c", "#eeccff", "#ada368", "#e9a6ce", "#48a297", "#ffc1df", "#799c7a", "#facbe0", "#5d9e9a", "#ffc6c1", "#619bb0", "#fccdcb", "#7197bb", "#b1e4c3", "#9390b1", "#c3e0c0", "#a98c90", "#ade3ce", "#9c927d", "#c2dafe", "#869881", "#e6d3dc", "#6e9ba4", "#bde0d0", "#8196a4", "#b2e1df", "#b9deea")
)
ltyInput <- function (id, name, val, none = TRUE) {
selectInput(id, paste(name, "line type"),
c(if (none) list("None" = "blank"),
list("Solid" = "solid", "Dotted" = "dotted",
"Dashed" = "dashed", "Dot-Dash" = "dotdash",
"Long-dash" = "longdash", "Two-dash" = "twodash")),
val)
}
pchInput <- function (id, name, val) {
selectInput(id, name,
list(
"Data column 4" = 904,
"Data column 5" = 905,
"Data column 6" = 906,
"Square" = 0,
"Circle" = 1,
"Triangle-up" = 2,
"Plus" = 3,
"Cross" = 4,
"Diamond" = 5,
"Triangle-down" = 6,
"Crossed-square" = 7,
"Star" = 8,
"Plussed-diamond" = 9,
"Plussed-circle" = 10,
"Snowflake" = 11,
"Plussed-square" = 12,
"Crossed-circle" = 13,
"Triangle-in-square" = 14,
"Filled square" = 15,
"Filled circle" = 16,
"Filled triangle" = 17,
"Filled diamond" = 18
),
val)
}
cexInput <- function (id, name, val) {
sliderInput(id, name, 0, 4, val, step = 0.01)
}
lwdInput <- function (id, name, val) {
sliderInput(id, paste(name, "line width"), 0, 6, val, step = 0.01)
}
fontInput <- function (id, name, val) {
selectInput(id, paste0(name, " font style"),
list("Plain" = 1, "Bold" = 2, "Italic" = 3, "Bold-italic" = 4),
val)
}
# Define UI for app that draws a histogram ----
ui <- fluidPage(title = "Ternary plotter", theme = "Ternary.css",
useShinyjs(),
sidebarLayout(
sidebarPanel(
tabsetPanel(
tabPanel("Load data",
tags$div("Upload a csv or spreadsheet, where the first three columns",
"list the co-ordinates of each point. Columns 4 to 6 may",
"be used to specify the points' style."),
fileInput("datafile", "Data", placeholder = "No data file selected",
accept = c(".csv", ".txt", ".xls", ".xlsx")),
textOutput(outputId = "dataStatus"),
textInput("dim1", "Column one", ""),
textInput("dim2", "Column two", ""),
textInput("dim3", "Column three", ""),
tags$p("Use the tabs above to edit display settings.")
),
tabPanel("Plot display",
selectInput("point", "Plot direction",
list("Up" = "up", "Right" = "right", "Down" = "down",
"Left" = "left"), "up"),
colourInput("col", "Background colour", "#ffffff"),
checkboxGroupInput("display", "Display options",
list("Clockwise" = "clockwise",
"Isometric" = "isometric",
"Tip labels" = "show.tip.labels",
"Axis labels" = "show.axis.labels",
"Axis tick labels" = "axis.labels",
"Axis tick marks" = "axis.tick",
"Rotate tick labels" = "axis.rotate"),
c("clockwise", "isometric", "axis.labels",
"show.axis.labels", "axis.tick", "axis.rotate")),
lwdInput("axis.lwd", "Axis", 1),
ltyInput("axis.lty", "Axis", "solid"),
colourInput("axis.col", "Axis colour", "black"),
lwdInput("ticks.lwd", "Axis ticks", 1),
sliderInput("ticks.length", "Axis tick length", 0, 0.1, 0.025),
colourInput("ticks.col", "Axis tick colour", "darkgrey"),
#axis.pos = NULL,
#xlim = NULL,
#ylim = NULL,
#atip.rotate = NULL,
#btip.rotate = NULL,
#ctip.rotate = NULL,
#atip.pos = NULL,
#btip.pos = NULL,
#ctip.pos = NULL,
#padding = 0.08,
#col = NA,
),
tabPanel("Grids",
sliderInput("grid.lines" , "Main grid lines", 1, 42, 10),
sliderInput("grid.minor.lines", "Minor grid lines:", 0, 10, 4),
colourInput("grid.col", "Grid colour", "darkgrey"),
colourInput("grid.minor.col", "Grid secondary colour", "lightgrey"),
ltyInput("grid.lty", "Grid", "solid"),
ltyInput("grid.minor.lty", "Secondary grid", "solid"),
lwdInput("grid.lwd", "Grid", par("lwd")),
lwdInput("grid.minor.lwd", "Secondary grid", par("lwd")),
),
tabPanel("Labels",
cexInput("lab.cex", "Axis label size", 1),
fontInput("lab.font", "Axis label", 1),
sliderInput("lab.offset", "Axis label offset", -0.3, 0.5, 0.16, step = 0.005),
colourInput("lab.col", "Axis label colour", "black"),
cexInput("axis.cex", "Tick label size", 0.8),
fontInput("axis.font", "Tick", par("font")),
cexInput("tip.cex", "Tip label size", 1),
fontInput("tip.font", "Tip" , 1),
colourInput("tip.col", "Tip colour", "black"),
),
tabPanel("Points",
selectInput("points.type", "Plot type",
list("Points only" = "p",
"Lines" = "l",
"Connected points" = "b",
"Text" = "text"),
"p"),
selectInput("text.source", "Text to display",
list("Row names" = 0,
"Data column 4" = 4,
"Data column 5" = 5,
"Data column 6" = 6),
0),
pchInput("points.pch", "Point shape", 16),
selectInput("points.col.by", "Point colour",
list("Data column 4" = 4,
"Data column 5" = 5,
"Data column 6" = 6,
"User-specified" = 0),
0),
colourInput("points.col", "Colour", "#222222"),
cexInput("points.cex", "Point size", 1.8),
lwdInput("points.lwd", "Connecting", 1),
ltyInput("points.lty", "Connecting", "solid", FALSE),
)
),
),
# Sidebar layout with input and output definitions ----
mainPanel(
tabsetPanel(
tabPanel("Plot",
fluidRow(plotOutput(outputId = "plot")),
fluidRow(id = "saveButtons",
tags$span("Save as: "),
downloadButton("saveR", "R script"),
downloadButton("savePdf", "PDF"),
downloadButton("savePng", "PNG"),
tags$span("PNG size: ", id = "pngSizeLabel"),
numericInput("pngSize", NULL, 800, 100,
width = "70px", step = 10),
tags$span("pixels"),
),
),
tabPanel("R code",
fluidRow(verbatimTextOutput("code")),
)
),
withTags(
div(id = "caption",
p("For additional features, see ",
a(href = "https://ms609.github.io/Ternary/articles/Ternary.html", "the package manual,"),
"or",
a(href = "https://github.com/ms609/TernaryApp/issues/new?title=Missing+feature:+",
"request"),
" their addition to this app."),
p("If using figures in a publication, please cite Smith (2017). ",
"\"Ternary: An R Package for Creating Ternary Plots.\" ",
"Comprehensive R Archive Network, doi:",
a(href = "https://dx.doi.org/10.5281/zenodo.1068996",
"10.5281/zenodo.1068996")
),
)
),
)
)
# References and notes
)
server <- function(input, output, session) {
r <- reactiveValues()
displaySetting <- function(id) id %in% input$display
filePath <- reactive({
fileInput <- input$datafile
exampleFile <- system.file("TernaryApp", "example.csv", package = "Ternary")
if (is.null(fileInput)) {
if (exampleFile == "") {
ghFile <- "https://raw.githubusercontent.com/ms609/TernaryApp/master/example.csv"
candidate <- tryCatch({
read.csv(ghFile)
output$dataStatus <- renderText(
"Data / example files not found; loaded from GitHub.")
ghFile
}, warning = function (e) {
output$dataStatus <- renderText(
"Data / example files not found; could not load from GitHub.")
""
})
} else {
output$dataStatus <- renderText(paste(
"Data file not found; using example from", exampleFile))
candidate <- exampleFile
}
} else {
candidate <- fileInput$datapath
if (is.null(candidate)) {
output$dataStatus <- renderText({"Data file not found; using example."})
candidate <- exampleFile
} else {
r$fileName <- fileInput$name
output$dataStatus <- renderText({paste0("Loaded data from ", fileInput$name)})
}
}
# Return:
candidate
})
fileExt <- reactive({
fp <- filePath()
if (nchar(fp) < 2) "<none>" else substr(fp, nchar(fp) - 3, nchar(fp))
})
myData <- reactive({
fp <- filePath()
ret <- switch(fileExt(),
".csv" = read.csv(fp),
".txt" = read.table(fp),
".xls" = readxl::read_excel(fp),
"xlsx" = readxl::read_excel(fp),
{
output$dataStatus <- renderText({
paste0("Unsupported file extension: ", fileExt())})
matrix(0, 0, 3)
}
)
cn <- colnames(ret)
updateTextInput(session, "dim1", value = cn[1])
updateTextInput(session, "dim2", value = cn[2])
updateTextInput(session, "dim3", value = cn[3])
ret
})
dataLabels <- reactive({
candidates <- colnames(ret)
if (is.null(candidates)) rep("", 3L) else candidates
})
axisLabels <- reactive({
if (displaySetting("show.axis.labels")) {
c(input$dim1, input$dim2, input$dim3)
} else rep(NULL, 3)
})
tipLabels <- reactive({
if (displaySetting("show.tip.labels")) {
c(input$dim1, input$dim2, input$dim3)
} else rep(NULL, 3)
})
PchValue <- function (pch) {
nPch <- as.numeric(pch)
if (nPch < 900L) nPch else as.numeric(myData()[, nPch - 900L])
}
PchText <- function (pch) {
nPch <- as.numeric(pch)
if (nPch < 900L) pch else paste0("myData[, ", nPch - 900L, "]")
}
DataCol <- function (i) {
if(ncol(myData()) >= i) myData()[, i] else {
message("Data only has ", ncol(myData()), " columns.")
0
}
}
PtCol <- function () {
switch (input$points.col.by,
"0" = input$points.col,
"4" = DataCol(4),
"5" = DataCol(5),
"6" = DataCol(6))
}
PtColTxt <- function () {
switch (input$points.col.by,
"0" = paste0("\"", input$points.col, "\""),
"4" = "myData[, 4]",
"5" = "myData[, 5]",
"6" = "myData[, 6]")
}
TextLabels <- function () {
switch(input$text.source,
"0" = if (is.null(rownames(myData()))) seq_len(nrow(myData())) else
rownames(myData()),
"4" = DataCol(4),
"5" = DataCol(5),
"6" = DataCol(6))
}
TextLabelsText <- function () {
switch (input$text.source,
"0" = if (is.null(rownames(myData()))) {
"seq_len(nrow(myData))"
} else {
"rownames(myData)"
},
"4" = "myData[, 4]",
"5" = "myData[, 5]",
"6" = "myData[, 6]")
}
observeEvent(input$points.type, {
if (input$points.type == "text") {
showElement("text.source")
} else {
hideElement("text.source")
}
if (input$points.type %in% c("p", "b")) {
showElement("points.pch")
} else {
hideElement("points.pch")
}
if (input$points.type %in% c("l", "b")) {
showElement("points.lwd")
showElement("points.lty")
} else {
hideElement("points.lwd")
hideElement("points.lty")
}
})
observeEvent(input$points.col.by, {
if (input$points.col.by == "0") {
showElement("points.col")
} else {
hideElement("points.col")
}
})
observeEvent(input$display, ignoreNULL = FALSE, {
tipLabelSetting <- if ("show.tip.labels" %in% input$display) {
showElement
} else {
hideElement
}
tipLabelSetting("tip.cex")
tipLabelSetting("tip.font")
tipLabelSetting("tip.col")
axisLabelSetting <- if ("show.axis.labels" %in% input$display) {
showElement
} else {
hideElement
}
axisLabelSetting("lab.cex")
axisLabelSetting("lab.font")
axisLabelSetting("lab.offset")
tickLabelSetting <- if ("axis.labels" %in% input$display) {
showElement
} else {
hideElement
}
tickLabelSetting("axis.cex")
tickLabelSetting("axis.font")
})
makePlot <- function () {
par(mar = rep(0, 4))
TernaryPlot(
atip = tipLabels()[1],
btip = tipLabels()[2],
ctip = tipLabels()[3],
alab = axisLabels()[1],
blab = axisLabels()[2],
clab = axisLabels()[3],
lab.offset = input$lab.offset,
lab.col = input$lab.col,
point = input$point,
clockwise = displaySetting("clockwise"),
xlim = NULL,
ylim = NULL,
lab.cex = input$lab.cex,
lab.font = as.numeric(input$lab.font),
tip.cex = input$tip.cex,
tip.font = as.numeric(input$tip.font),
tip.col = input$tip.col,
isometric = displaySetting("isometric"),
atip.rotate = NULL,
btip.rotate = NULL,
ctip.rotate = NULL,
atip.pos = NULL,
btip.pos = NULL,
ctip.pos = NULL,
padding = 0.08,
col = input$col,
grid.lines = input$grid.lines,
grid.col = input$grid.col,
grid.lty = input$grid.lty,
grid.lwd = input$grid.lwd,
grid.minor.lines = input$grid.minor.lines,
grid.minor.col = input$grid.minor.col,
grid.minor.lty = input$grid.minor.lty,
grid.minor.lwd = input$grid.minor.lwd,
axis.lty = input$axis.lty,
axis.labels = displaySetting("axis.labels"),
axis.cex = input$axis.cex,
axis.font = as.numeric(input$axis.font),
axis.rotate = displaySetting("axis.rotate"),
#axis.pos = input$axis.pos,
axis.tick = displaySetting("axis.tick"),
axis.lwd = input$axis.lwd,
ticks.lwd = input$ticks.lwd,
ticks.length = input$ticks.length,
axis.col = input$axis.col,
ticks.col = input$ticks.col
)
if (input$points.type == "text") {
TernaryText(myData()[, 1:3],
labels = TextLabels(),
cex = input$points.cex,
pch = PchValue(input$points.pch),
col = PtCol()
)
} else {
if (dim(myData())[1] > 0) {
TernaryPoints(myData()[, 1:3],
cex = input$points.cex,
pch = PchValue(input$points.pch),
lwd = input$points.lwd,
lty = input$points.lty,
col = PtCol(),
type = input$points.type)
}
}
}
rScript <- function() {
paste0(
"# Include the full path to your data file here if necessary:\n",
"myData <- ", switch(fileExt(), ".csv" = "read.csv",
".txt" = "read.table",
".xls" = "readxl::read_excel",
"xlsx" = "readxl::read_excel", "read.csv"),
"(\"", r$fileName, "\")\n\n",
"TernaryPlot(
atip = \"", tipLabels()[1], "\",
btip = \"", tipLabels()[2], "\",
ctip = \"", tipLabels()[3], "\",
alab = \"", axisLabels()[1], "\",
blab = \"", axisLabels()[2], "\",
clab = \"", axisLabels()[3], "\",
lab.offset = ", input$lab.offset, ",
lab.col = \"", input$lab.col, "\",
point = \"", input$point, "\",
clockwise = ", displaySetting("clockwise"), ",
xlim = NULL,
ylim = NULL,
lab.cex = ", input$lab.cex, ",
lab.font = ", input$lab.font, ",
tip.cex = ", input$tip.cex, ",
tip.font = ", input$tip.font, ",
tip.col = \"", input$tip.col, "\",
isometric = ", displaySetting("isometric"), ",
atip.rotate = NULL,
btip.rotate = NULL,
ctip.rotate = NULL,
atip.pos = NULL,
btip.pos = NULL,
ctip.pos = NULL,
padding = 0.08,
col = \"", input$col, "\",
grid.lines = ", input$grid.lines, ",
grid.col = \"", input$grid.col, "\",
grid.lty = \"", input$grid.lty, "\",
grid.lwd = ", input$grid.lwd, ",
grid.minor.lines = ", input$grid.minor.lines, ",
grid.minor.col = \"", input$grid.minor.col, "\",
grid.minor.lty = \"", input$grid.minor.lty, "\",
grid.minor.lwd = ", input$grid.minor.lwd, ",
axis.lty = \"", input$axis.lty, "\",
axis.labels = ", displaySetting("axis.labels"), ",
axis.cex = ", input$axis.cex, ",
axis.font = ", input$axis.font, ",
axis.rotate = ", displaySetting("axis.rotate"), ",
axis.tick = ", displaySetting("axis.tick"), ",
axis.lwd = ", input$axis.lwd, ",
ticks.lwd = ", input$ticks.lwd, ",
ticks.length = ", input$ticks.length, ",
axis.col = \"", input$axis.col, "\",
ticks.col = \"", input$ticks.col, "\"
)\n\n",
if (input$points.type == "text") {
paste0(
"TernaryText(myData[, 1:3],
labels = ", TextLabelsText(), ",
cex = ", input$points.cex, ",
pch = ", PchText(input$points.pch), ",
col = \"", input$points.col, "\"\n)")
} else {
paste0("TernaryPoints(myData[, 1:3],
type = \"", input$points.type, "\",
cex = ", input$points.cex, ",
pch = ", PchText(input$points.pch), ",
lwd = ", input$points.lwd, ",
lty = \"", input$points.lty, "\",
col = ", PtColTxt(), "\n)")
}
)
}
output$plot <- renderPlot(makePlot())
output$code <- renderText(rScript())
output$savePng <- downloadHandler(
filename = "TernaryPlot.png",
content = function (file) {
png(file, width = input$pngSize, height = input$pngSize)
makePlot()
dev.off()
})
output$savePdf <- downloadHandler(
filename = "TernaryPlot.pdf",
content = function (file) {
pdf(file,
title = paste0("Ternary plot",
if(filePath() != "") paste0(" from ", filePath())))
makePlot()
dev.off()
})
output$saveR <- downloadHandler(
filename = "TernaryPlot.R",
content = function (file) {
writeLines(rScript(), file)
})
}
shinyApp(ui = ui, server = server)
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.