Related
I have a problem with the shiny app in that the plots does not change when I choose different input values in the app. In my example I want to choose different "miRNA" resulting in a different survival-plot
Here is my app:
library(dplyr)
require(survminer)
library(tidyverse)
require(reshape2)
library(shiny)
library(tidyr)
require(survival)
example data:
df.miRNA.cpm <- structure(list(`86` = c(5.57979757386892, 17.0240095264258, 4.28380151026145,
13.0457611762755, 12.5531123449841), `175` = c(5.21619202802748,
15.2849097474841, 2.46719979911461, 10.879496005461, 9.66416497290915
), `217` = c(5.42796072966512, 17.1413407297933, 5.15230233060323,
12.2646127361351, 12.1031024927547), `394` = c(-1.1390337316217,
15.1021660424984, 4.63168157763046, 11.1299079134792, 9.55572588729967
), `444` = c(5.06134249676025, 14.5442494311861, -0.399445049232868,
7.45775961504073, 9.92629675808998)), row.names = c("hsa_let_7a_3p",
"hsa_let_7a_5p", "hsa_let_7b_3p", "hsa_let_7b_5p", "hsa_let_7c_5p"
), class = "data.frame")
df.miRNA.cpm$miRNA <- rownames(df.miRNA.cpm)
ss.survival.shiny.miRNA.miRNA <- structure(list(ID = c("86", "175", "217", "394", "444"), TimeDiff = c(71.0416666666667,
601.958333333333, 1130, 1393, 117.041666666667), Status = c(1L,
1L, 0L, 0L, 1L)), row.names = c(NA, 5L), class = "data.frame")
Joint the two example data frames:
data_prep.miRNA <- df.miRNA.cpm %>%
tidyr::pivot_longer(-miRNA, names_to = "ID") %>%
left_join(ss.survival.shiny.miRNA.miRNA)
Example of the joined data:
> data_prep.miRNA
# A tibble: 153,033 x 5
miRNA ID value TimeDiff Status
<chr> <chr> <dbl> <dbl> <int>
1 hsa_let_7a_3p 86 5.58 71.0 1
2 hsa_let_7a_3p 175 5.22 602. 1
3 hsa_let_7a_3p 217 5.43 1130 0
4 hsa_let_7a_3p 394 -1.14 1393 0
5 hsa_let_7a_3p 444 5.06 117. 1
6 hsa_let_7a_3p 618 4.37 1508 0
7 hsa_let_7a_3p 640 2.46 1409 0
8 hsa_let_7a_3p 829 0.435 919. 0
9 hsa_let_7a_3p 851 -1.36 976. 0
10 hsa_let_7a_3p 998 3.87 1196. 0
# … with 153,023 more rows
Shiny:
ui.miRNA <- fluidPage(
selectInput("MicroRNA", "miRNA", choices = unique(data_prep.miRNA$miRNA)),
plotOutput("myplot"))
server <- function(input, output, session) {
data_selected <- reactive({
filter(data_prep.miRNA, miRNA %in% input$MicroRNA)
})
output$myplot <- renderPlot({
survfit(Surv(TimeDiff, Status) ~ cut(value, quantile(value, probs = c(0, .4, .8)), include.lowest=TRUE),data = data_selected())
ggsurvplot(fitSurv)
})
}
shinyApp(ui.miRNA, server)
You have to assign the output of survfit to fitSurv:
output$myplot <- renderPlot({
fitSurv <- survfit(Surv(TimeDiff, Status) ~ cut(value, quantile(value, probs = c(0, .4, .8)), include.lowest=TRUE),data = data_selected())
ggsurvplot(fitSurv)
})
New to Shiny, I am trying to create a very simple app respecting the following sequence of events:
(1) Upload a dataframe,
(2) Wait until the user set the filtering parameter (Category in the example below),
(3) Press a Go! button,
(4) Display the first rows of the subset data frame.
Let's say I have a file df.tab to upload and process.
df <- data.frame(Category=c("A","A","A","B","B","B"), X=c(1,2,3,1,2,3), Y=c(1,2,3,34,21,1))
df
Category X Y
1 A 1 1
2 A 2 2
3 A 3 3
4 B 1 34
5 B 2 21
6 B 3 1
write.table(df, file="df.tab", row.names=F, quote=F, sep="\t")
My app.R looks like:
library(shiny)
# Define UI ----
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
fileInput("input_df",label=h4("Dataset")),
selectInput("category",h4("Category"), choices = list("A" = 1,"B" = 2),selected = 1),
actionButton("goButton",label = "Go!")
),
mainPanel(
tableOutput("view")
)
)
)
# Define server logic ----
server <- function(input, output) {
data <- eventReactive(
input$input_df,
{
File <- input$input_df
if(is.null(File)){
return(NULL)
}else{
df <- read.table(File$datapath, header = T, sep = "\t")
}
}
)
data_sub <- eventReactive(
input$category,
{
df_sub <- subset(data(), Category == input$category)
}
)
output$view <- renderTable(
{
head(data_sub())
}
)
}
# Run the app ----
shinyApp(ui = ui, server = server)
However, the app is either not responsive or does not display any rows.
Note that I created 2 distinct reactive events data and data_sub in order to avoid loading the file every time I select a different category (and potentially to avoid stack errors with a recursive function).
Any help would be greatly appreciated.
Here is a working server function. Use reactive, not eventReactive and it is quite straightforward.
NOTE that your example assumes you have a Category column, I modified below to make it work with anything.
# Define server logic ----
server <- function(input, output) {
dataset <- reactive({
File <- input$input_df
req(File)
read.table(File$datapath, header = TRUE, sep = "\t")
})
data_sub <- reactive({
if("Category" %in% names(dataset())){
subset(dataset(), Category == input$category)
} else {
dataset()
}
})
output$view <- renderTable({
head(data_sub())
})
}
I want to reproduce the example at: https://scip.shinyapps.io/scip_app/
Basically, I have a 300 by 300 adjusted correlation matrix and a 300 by 300 unadjusted correlation matrix and want to show them interactively with zoom in and zoom out function. The text descriptions should display the point estimates and confidence intervals.
Is there any template I can quickly refer to?
Building on the data from Mike, you can use the d3heatmap library
library(d3heatmap)
library(shiny)
n1 <- 100
n2 <- 100
nr <- 30
nc <- 30
set.seed(1)
x <- matrix(rnorm(n1), nrow=nr, ncol=nc)
y <- matrix(rnorm(n2), nrow=nr, ncol=nc)
MAT <- cor(x,y)
ui <- fluidPage(
mainPanel(
d3heatmapOutput("heatmap", width = "100%", height="600px")
)
)
## server.R
server <- function(input, output) {
output$heatmap <- renderD3heatmap({d3heatmap(MAT)})
}
shinyApp(ui = ui, server = server)
Edit: Specify the colours if needs to be and display the data as is, note that Colv = T by default, which means it will group the correlated items together
output$heatmap <- renderD3heatmap({d3heatmap(MAT, colors = "Blues", Colv = FALSE)})
I think plotly can do this well. Here are the docs https://plot.ly/r/heatmaps/:
And here is a little template-example (returning Porkchop's favor by borrowing his minimal shiny template) with some fake data:
library(shiny)
n1 <- 100
n2 <- 100
nr <- 30
nc <- 30
set.seed(1)
x <- matrix(rnorm(n1), nrow=nr, ncol=nc)
y <- matrix(rnorm(n2), nrow=nr, ncol=nc)
cmat <- cor(x,y)
plot_ly(z = cmat, type = "heatmap")
ui <- fluidPage(
mainPanel(
plotlyOutput("heatmap", width = "100%", height="600px")
)
)
## server.R
server <- function(input, output) {
output$heatmap <- renderPlotly({plot_ly(z = cmat, type = "heatmap")})
}
shinyApp(ui,server)
Here is the Shiny output. Note it is fully zoomable:
When using a for loop to render some plots I obtained results I didn't understand. All plots became equal to the (intended) last one. I hope to make this more clear in the example below. Note the plot1 shows a '6' (the last one), not a '5' (as intended).
Can anyone explain this and/or give a solution avoid this kind of behaviour.
shiny ui:
shinyUI (fluidPage(
fluidRow (
column (6, plotOutput ('plot1', height = "180px")),
column (6, plotOutput ('plot2', height = "180px"))
),
fluidRow (
column (6, plotOutput ('plot3', height = "180px")),
column (6, plotOutput ('plot4', height = "180px"))
)
))
shiny server:
shinyServer (function (input, output, session) {
require (ggplot2)
plotId <- c('plot1', 'plot2', 'plot3', 'plot4')
pw <- initPlotWindows ()
output[['plot1']] <- renderPlot ({pw[[1]]})
output[['plot2']] <- renderPlot ({pw[[2]]})
output[['plot3']] <- renderPlot ({pw[[3]]})
output[['plot4']] <- renderPlot ({pw[[4]]})
id <- 'plot1'
i <- 5
output[[id]] <- renderPlot ({pw[[i]]})
id <- 'plot3'
i <- 6
# output[[id]] <- renderPlot ({pw[[i]]})
})
initPlotWindows <- function () {
pw <- vector (mode = 'list', length = 6) # plot window data
for (i in 1:6) pw[[i]] <- p_empty (plotN = i)
pw
}
p_empty <- function (plotN) {
p <- ggplot()
p <- p + annotate("text", label = plotN, x = .5, y = .5, size = 20, colour = "grey")
p <- p + theme(axis.ticks.x = element_blank(), axis.text.x = element_blank(), axis.title.x=element_blank())
p <- p + theme(axis.ticks.y = element_blank(), axis.text.y = element_blank(), axis.title.y=element_blank())
p
}
Resulting output. Plot1 contains a 6 not a 5!
The reason why this happens is because shiny does not execute your server side code line by line. Shiny executes all of the non-reactive code once at the beginning. But renderPlot() and other reactive code will only run when it is necessary. (when they are called)
So what happened is, it assigned 5, and then 6 to i, and only rendered the plot afterwards.
output[[id]] <- renderPlot ({
print("section D")
pw[[i]]})
You can check it pretty easily in the R console using the print() function:
shinyServer (function (input, output, session) {
print("section A")
require (ggplot2)
plotId <- c('plot1', 'plot2', 'plot3', 'plot4')
pw <- initPlotWindows ()
output[['plot1']] <- renderPlot ({
print("section B1")
pw[[1]]})
output[['plot2']] <- renderPlot ({
print("section B2")
pw[[2]]})
output[['plot3']] <- renderPlot ({
print("section B3")
pw[[3]]})
output[['plot4']] <- renderPlot ({
print("section B4")
pw[[4]]})
print("section C")
id <- 'plot1'
i <- 5
output[[id]] <- renderPlot ({
print("section D")
pw[[i]]})
print("section E")
id <- 'plot3'
i <- 6
# output[[id]] <- renderPlot ({pw[[i]]})
})
Console output:
[1] "section A"
[1] "section C"
[1] "section E"
[1] "section B1"
[1] "section B2"
[1] "section B3"
[1] "section B4"
[1] "section D"
Edit:
As for the output[[id]], id gets evaluated at the beginning, so output[[id]] becomes output[[plot1]]. But pw[[i]] is only evaluated when shiny asks the plot to render, which is after the value has been set to 5 and then to 6.
If you want plot1 to show 5, then you could assign id outside of renderPlot(), and assign i inside of renderPlot():
id <- 'plot1'
output[[id]] <- renderPlot ({
i <- 5
pw[[i]]})
Thank you GyD,
From your answer I conclude that a normal for-loop is not possible. The running variable 'i' would than be defined outside and not inside renderPlot().
So it seems that I have to use eval (parse()) for at least renderPlot().
A for-loop like:
for ( i in 1:4) {
pltId <- paste ('plot', i, sep='')
output[[pltId]] <- renderPlot ({pw[i]})
}
would then become (using eval(parse()) for the whole assignment):
for ( i in 1:4) {
eval (parse (text = paste ("output[['plot", i, "']] <- renderPlot ({pw[", i, "]})", sep='')))
}
Your answer should work, but you could generate both the UI elements and the server side with loops. (don't know if that interests you)
I am not a huge fan of for loops in R, so I'm using lapply.
library(shiny)
library(ggplot2)
# I want to plot these elements
vec <- c(5, 2, 3, 4)
# Defining some functions
initPlotWindows <- function () {
pw <- vector (mode = 'list', length = 6) # plot window data
for (i in vec) pw[[i]] <- p_empty (plotN = i)
pw
}
p_empty <- function (plotN) {
p <- ggplot()
p <- p + annotate("text", label = plotN, x = .5, y = .5, size = 20, colour = "grey")
p <- p + theme(axis.ticks.x = element_blank(), axis.text.x = element_blank(), axis.title.x=element_blank())
p <- p + theme(axis.ticks.y = element_blank(), axis.text.y = element_blank(), axis.title.y=element_blank())
p
}
# Creating pw list
pw <- initPlotWindows()
ui <- fluidPage(
# Creating UI from loop
lapply(vec, function(i) {
column(6, plotOutput(paste0('plot', i), height = "180px"))
})
)
server <- function(input, output, session){
# Generating UI output from loop
lapply(vec, function(i) {
output[[paste0('plot', i)]] <- renderPlot({
pw[[i]]
})
})
}
shinyApp(ui, server)
I wish to split strings into non-overlapping segments where the endpoints of a segment are numbers within a field of dots. I can do this using the code below. However, this code seems to be overly complex and involves nested for-loops. Is there a simpler way, ideally using regex in base R?
Here is an example and the desired.result.
my.data <- read.table(text = '
my.string cov1 cov2
11....... 1 A
1.1.2.1.1 2 B
1234..... 3 C
1...2...3 4 C
..3..4... 5 D
', header = TRUE, stringsAsFactors = FALSE)
desired.result <- read.table(text = '
my.string cov1 cov2
11....... 1 A
1.1...... 2 B
..1.2.... 2 B
....2.1.. 2 B
......1.1 2 B
12....... 3 C
.23...... 3 C
..34..... 3 C
1...2.... 4 C
....2...3 4 C
..3..4... 5 D
', header = TRUE, stringsAsFactors = FALSE, na.strings = 'NA')
new.data <- data.frame(do.call(rbind, strsplit(my.data$my.string,'')), stringsAsFactors = FALSE)
n.segments <- rowSums(!(new.data[1:ncol(new.data)] == '.')) - 1
my.end.points <- do.call(rbind, gregexpr("[0-9]", my.data$my.string, perl=TRUE))
my.end.point.char <- do.call(rbind, strsplit(my.data$my.string, ""))
my.end.point.char <- t(apply(my.end.point.char, 1, as.numeric))
new.strings <- matrix('.', nrow = sum(n.segments), ncol = max(nchar(my.data$my.string)))
new.cov <- as.data.frame(matrix(NA, nrow = sum(n.segments), ncol = (ncol(my.data) - 1)))
m <- 1
for(i in 1:nrow(new.data)) {
for(j in 1:n.segments[i]) {
for(k in 1:ncol(new.strings)) {
new.strings[m, my.end.points[i, j ] ] <- my.end.point.char[i, my.end.points[i, j ]]
new.strings[m, my.end.points[i, (j+1)] ] <- my.end.point.char[i, my.end.points[i,(j+1)]]
new.cov[m,] <- my.data[i, c(2:ncol(my.data))]
}
m <- m + 1
}
}
my.result <- data.frame(my.string = apply(new.strings, 1, function(x) paste0(x, collapse = '')), stringsAsFactors = FALSE)
my.result <- data.frame(my.result, new.cov)
colnames(my.result) <- names(my.data)
all.equal(desired.result, my.result)
# [1] TRUE
w <- nchar(my.data$my.string[1L]);
dps <- character(w+1L); dps[1L] <- ''; for (i in seq_len(w)) dps[i+1L] <- paste0(dps[i],'.');
x <- Map(my.data$my.string,gregexpr('[^.]',my.data$my.string),f=function(s,g)
if (length(g)<3L) s else sapply(seq_len(length(g)-1L),function(gi)
paste0(dps[g[gi]],substr(s,g[gi],g[gi+1L]),dps[w-g[gi+1L]+1L])
)
);
res <- transform(my.data[rep(seq_len(nrow(my.data)),sapply(x,length)),],my.string=unlist(x));
res;
## my.string cov1 cov2
## 1 11....... 1 A
## 2 1.1...... 2 B
## 2.1 ..1.2.... 2 B
## 2.2 ....2.1.. 2 B
## 2.3 ......1.1 2 B
## 3 12....... 3 C
## 3.1 .23...... 3 C
## 3.2 ..34..... 3 C
## 4 1...2.... 4 C
## 4.1 ....2...3 4 C
## 5 ..3..4... 5 D
Note: You can replace the sapply(x,length) piece with lengths(x) if you have a recent enough version of R.
Benchmarking
library(microbenchmark);
bgoldst <- function(my.data) { w <- nchar(my.data$my.string[1L]); dps <- character(w+1L); dps[1L] <- ''; for (i in seq_len(w)) dps[i+1L] <- paste0(dps[i],'.'); x <- Map(my.data$my.string,gregexpr('[^.]',my.data$my.string),f=function(s,g) if (length(g)<3L) s else sapply(seq_len(length(g)-1L),function(gi) paste0(dps[g[gi]],substr(s,g[gi],g[gi+1L]),dps[w-g[gi+1L]+1L]))); transform(my.data[rep(seq_len(nrow(my.data)),sapply(x,length)),],my.string=unlist(x)); };
rawr <- function(my.data) { f <- function(x, m) { y <- gsub('.', '\\.', x); cs <- attr(m, "capture.start"); cl <- attr(m, "capture.length"); Vectorize(`substr<-`)(y, cs, cl + cs - 1, Vectorize(substr)(x, cs, cl + cs - 1)); }; m <- gregexpr('(?=([0-9][.]*[0-9]))', my.data$my.string, perl = TRUE); strs <- Map(f, my.data$my.string, m); tmp <- `rownames<-`(my.data[rep(1:nrow(my.data), sapply(strs,length)), ], NULL); tmp$my.string <- unlist(strs); tmp; };
carroll <- function(my.data) { strings <- sapply(my.data$my.string, function(x) { stri_match_all_regex(x, "(?=([0-9]{1}\\.*[0-9]{1}))")[[1]][,2]; }); strpos <- lapply(1:length(strings), function(x) { y <- {nchar(sub(perl=T,'^\\.*\\K.*','',my.data$my.string[x]))+c(0, cumsum(nchar(strings[[x]])-1))}; return(y[-length(y)]); }); w <- nchar(my.data$my.string[1L]); output.result <- data.frame(my.string = cbind(unlist(sapply(1:length(strings), function(y) { cbind(sapply(1:length(strings[[y]]), function(x) { leftstr <- paste0(paste0(rep(".", strpos[[y]][[x]]), collapse=""), strings[[y]][x]); rightstr <- paste0(rep(".", w-nchar(leftstr)), collapse=""); paste0(leftstr, rightstr, collapse=""); })); }))), my.data[unlist(sapply(1:length(strings), function(x) { rep(x, sapply(strings, length)[x]); })), c(2,3)], stringsAsFactors=FALSE); row.names(output.result) <- NULL; output.result; };
## OP's sample input
my.data <- read.table(text = '
my.string cov1 cov2
11....... 1 A
1.1.2.1.1 2 B
1234..... 3 C
1...2...3 4 C
..3..4... 5 D
', header = TRUE, stringsAsFactors = FALSE);
ex <- bgoldst(my.data);
all.equal(ex,rawr(my.data),check.attributes=F);
## [1] TRUE
all.equal(ex,carroll(my.data),check.attributes=F);
## [1] TRUE
microbenchmark(bgoldst(my.data),rawr(my.data),carroll(my.data));
## Unit: microseconds
## expr min lq mean median uq max neval
## bgoldst(my.data) 422.094 451.816 483.5305 476.6195 503.775 801.421 100
## rawr(my.data) 1096.502 1160.863 1277.7457 1236.7720 1298.996 3092.785 100
## carroll(my.data) 1130.287 1176.900 1224.6911 1213.2515 1247.249 1525.437 100
## scale test
set.seed(1L);
NR <- 1e4; NS <- 30L; probDot <- 3/4;
x <- c('.',0:9); probs <- c(probDot,rep((1-probDot)/10,10L)); my.data <- data.frame(my.string=do.call(paste0,as.data.frame(replicate(NS,sample(x,NR,T,probs)))),cov1=sample(seq_len(NR)),cov2=sample(make.unique(rep(LETTERS,len=NR))),stringsAsFactors=F);
repeat { w <- which(sapply(gregexpr('[^.]',my.data$my.string),length)==1L); if (length(w)==0L) break; my.data$my.string[w] <- do.call(paste0,as.data.frame(replicate(NS,sample(x,length(w),T,probs)))); }; ## prevent single-digit strings, which rawr and carroll solutions don't support
ex <- bgoldst(my.data);
all.equal(ex,rawr(my.data),check.attributes=F);
## [1] TRUE
all.equal(ex,carroll(my.data),check.attributes=F);
## [1] TRUE
microbenchmark(bgoldst(my.data),rawr(my.data),carroll(my.data),times=1L);
## Unit: milliseconds
## expr min lq mean median uq max neval
## bgoldst(my.data) 904.887 904.887 904.887 904.887 904.887 904.887 1
## rawr(my.data) 2736.462 2736.462 2736.462 2736.462 2736.462 2736.462 1
## carroll(my.data) 108575.001 108575.001 108575.001 108575.001 108575.001 108575.001 1
my.data <- read.table(text = '
my.string cov1 cov2
11....... 1 A
1.1.2.1.1 2 B
1234..... 3 C
1...2...3 4 C
..3..4... 5 D
', header = TRUE, stringsAsFactors = FALSE)
f <- function(x, m) {
if (nchar(gsub('.', '', x, fixed = TRUE)) < 2L) return(x)
y <- gsub('.', '\\.', x)
cs <- attr(m, "capture.start")
cl <- attr(m, "capture.length")
Vectorize(`substr<-`)(y, cs, cl + cs - 1, Vectorize(substr)(x, cs, cl + cs - 1))
}
m <- gregexpr('(?=([0-9][.]*[0-9]))', my.data$my.string, perl = TRUE)
strs <- Map(f, my.data$my.string, m)
tmp <- `rownames<-`(my.data[rep(1:nrow(my.data), lengths(strs)), ], NULL)
tmp$my.string <- unlist(strs)
# my.string cov1 cov2
# 1 11....... 1 A
# 2 1.1...... 2 B
# 3 ..1.2.... 2 B
# 4 ....2.1.. 2 B
# 5 ......1.1 2 B
# 6 12....... 3 C
# 7 .23...... 3 C
# 8 ..34..... 3 C
# 9 1...2.... 4 C
# 10 ....2...3 4 C
# 11 ..3..4... 5 D
identical(tmp, desired.result)
# [1] TRUE
Here's an option. Not clean, but neither is the problem.
library(stringi)
## isolate the strings, allowing overlap via positive lookaheads
strings <- sapply(my.data$my.string, function(x) {
stri_match_all_regex(x, "(?=([0-9]{1}\\.*[0-9]{1}))")[[1]][,2]
})
Identify the offsets at the start of each group.
## identify the . offsets
strpos <- lapply(1:length(strings), function(x) {
y <- {nchar(sub(perl=T,'^\\.*\\K.*','',my.data$my.string[x]))+c(0, cumsum(nchar(strings[[x]])-1))}
return(y[-length(y)])
})
Build up the data.frame with only 2 sapply loops.
## collate the results using sapply
w <- nchar(my.data$my.string[1L]);
output.result <- data.frame(
my.string = cbind(unlist(sapply(1:length(strings), function(y) {
cbind(sapply(1:length(strings[[y]]), function(x) {
leftstr <- paste0(paste0(rep(".", strpos[[y]][[x]]), collapse=""), strings[[y]][x])
rightstr <- paste0(rep(".", w-nchar(leftstr)), collapse="")
paste0(leftstr, rightstr, collapse="")
}))
}))),
my.data[unlist(sapply(1:length(strings), function(x) {
rep(x, sapply(strings, length)[x])
})), c(2,3)], stringsAsFactors=FALSE
)
row.names(output.result) <- NULL
output.result
my.string cov1 cov2
1 11....... 1 A
2 1.1...... 2 B
3 ..1.2.... 2 B
4 ....2.1.. 2 B
5 ......1.1 2 B
6 12....... 3 C
7 .23...... 3 C
8 ..34..... 3 C
9 1...2.... 4 C
10 ....2...3 4 C
11 ..3..4... 5 D
identical(desired.result, output.result)
[1] TRUE