I am plotting a matrix using heatmaply and plotly
I want to make the plotylOutput height and width reactive to the size of the matrix
If I use a reactive value in the plotlyOutput width argument I get the following error:
Error in htmltools::validateCssUnit: CSS units must be a single-element numeric or character vector
See below for a minimum version of my code:
library(shiny)
library(heatmaply)
library(plotly)
ui <- tags$div(id = "placeholderimage", uiOutput("plotlyimage"))
server <- shinyServer(function(input, output, session) {
matsample <- reactive({cbind(c("A","A","A","T"),c("A","A","A","T"),c("A","A","A","G"))})
ranges <- reactiveValues(width_im = NULL,height_im=NULL)
ranges$width_im <- reactive(ncol(matsample())*20)
ms <- reactive({
alph <- c("A"=1, "C"=2, "G"=3, "T"=4, "-"=5, "N"=6, "S"=7)
ms <- matrix(alph[matsample()], ncol = ncol(matsample()), byrow=FALSE))
rownames(ms) <- rownames(matsample())
return(ms)
})
mm <- reactive({
data.frame(do.call(rbind, lapply(rownames(ms()), rep, ncol(matsample()))))
})
output$matimage <- renderPlotly({
heatmaply(ms(), custom_hovertext = mm(),
cellnote = matsample(),cellnote_size = 6,
cellnote_textposition = "middle center",
fontsize_col = 6,grid_gap = 1,grid_size = 0.01,
show_dendrogram = c(FALSE, FALSE),
Rowv=NULL, Colv=NULL, color=rainbow(7),
hide_colorbar=FALSE, plot_method = "plotly")
})
output$plotlyimage <- renderUI(
tags$div(class="superbigimage",
plotlyOutput("testplot", **width = isolate(ranges$width_im)**)
)
})
This code currently throws the error because of width = isolate(ranges$width_im), how can I make the width reactive to size of matrix?
Note my real work has matrices with over 600 columns
I forgot brackets and did not need to use isolate
output$plotlyimage <- renderUI(
tags$div(class="superbigimage",
plotlyOutput("testplot", width = ranges$width_im())
)
Related
The three images below help explain. MWE Code 1 reactively interpolates user input values as shown in the 1st image, but the user input matrix needs to instead expand horizontally to the right in pairings of two values to interpolate rather than the vertical (downward) expansion currently used in MWE Code 1. A horizontally expanding matrix with input pairings of two values is shown in the 2nd image and its code in MWE Code 2 below. MWE Code 2 isn't completely functional like MWE Code 1 but it illustrates the desired horizontally-expanding matrix in value pairings of two.
Note how in MWE Code 2 the two input variables to interpolate are “paired” or grouped under a single column heading labelled “Scenario 1”, “Scenario 2”, etc.. This pairing is necessary. A formula for skipping along a matrix that horizontally expands in groupings of two columns is shown in MWE Code 2, with trunc(1:ncol(mm)/2)+1.
How to modify MWE Code 1 so it expands horizontally like MWE Code 2, rather than vertically as it currently does?
It’s easy enough to change the parameters for the matrixInput function to reorient its expansion and pairings, as done in MWE Code 2; the tricky part is modifying the functions that feed off the matrix especially in the section starting plotData <- reactive({… with its use of lapply..., etc. in MWE Code 1.
MWE Code 1:
library(shiny)
library(shinyMatrix)
library(dplyr)
library(ggplot2)
interpol <- function(a, b) { # a = periods, b = matrix inputs
c <- rep(NA, a)
c[1] <- b[1]
c[a] <- b[2]
c <- approx(seq_along(c)[!is.na(c)], c[!is.na(c)], seq_along(c))$y # this interpolates
return(c)
}
ui <- fluidPage(
sliderInput('periods','Periods to interpolate:',min=2,max=10,value=10),
matrixInput(
"myMatrixInput",
label = "Values to interpolate (myMatrixInput):",
value = matrix(c(1, 5), 1, 2, dimnames = list("Scenario 1", c("Value 1", "Value 2"))),
cols = list(extend = FALSE, names = TRUE, editableNames = FALSE),
rows = list(names = TRUE,delete = TRUE, extend = TRUE, delta = 1),
class = "numeric"),
plotOutput("plot")
)
server <- function(input, output, session) {
sanitizedMat <- reactiveVal()
observeEvent(input$myMatrixInput, {
if(any(rownames(input$myMatrixInput) == "")){
tmpMatrix <- input$myMatrixInput
rownames(tmpMatrix) <- paste("Scenario", seq_len(nrow(input$myMatrixInput)))
updateMatrixInput(session, inputId = "myMatrixInput", value = tmpMatrix)
}
sanitizedMat(na.omit(input$myMatrixInput))
})
plotData <- reactive({
req(dim(sanitizedMat())[1] >= 1)
lapply(seq_len(nrow(sanitizedMat())),
function(i){
tibble(
Scenario = rownames(sanitizedMat())[i],
X = 1:input$periods,
Y = interpol(input$periods, sanitizedMat()[i, 1:2])
)
}) %>% bind_rows()
})
output$plot <- renderPlot({
req(nrow(plotData()) > 0)
plotData() %>% ggplot() + geom_line(aes(
x = X,
y = Y,
colour = as.factor(Scenario)
))
})
}
shinyApp(ui, server)
MWE Code 2 (uses same packages and interpol() function as above):
ui <- fluidPage(
sliderInput('input1','Interpolate over periods (X):',min=2,max=12,value=6),
matrixInput("input2",
label = "Input into empty 2nd row cells to add interpolation scenario:",
value = matrix(c(1, 5), 1, 2, dimnames = list("Begin|end value", c("Scenario 1", ""))),
rows = list(names = TRUE),
cols = list(names = TRUE,
extend = TRUE,
delta = 2,
delete = TRUE,
multiheader=TRUE),
class = "numeric"),
actionButton("add","Add scenario"),
plotOutput("plot")
)
server <- function(input, output, session){
results <- function(){interpol(req(input$input1),req(input$input2))}
numScenarios <- reactiveValues(numS=1)
observeEvent(input$add,{numScenarios$numS <- (numScenarios$numS+1)})
observe({
req(input$input2)
mm <- input$input2
colnames(mm) <- paste("Scenario ", trunc(1:ncol(mm)/2)+1)
isolate(updateMatrixInput(session, "input2", mm))
})
output$plot <-renderPlot({
req(input$input1,input$input2)
v <- lapply(
1:numScenarios$numS,
function(i) tibble(Scenario=i,X=1:input$input1,Y=results())
) %>%
bind_rows()
v %>% ggplot() +
geom_line(aes(x=X, y=Y, colour=as.factor(Scenario))) +
geom_point(aes(x=X, y=Y))
})
}
shinyApp(ui, server)
Refer to post on 17 Oct, 2021, which completely addresses the question and improves the below code, removing some bugs when deleting inputs: "How to automatically delete a matrix column in R if there otherwise would be subscript out of bounds error?"
Apologies for the cumbersome question. The below code provides a solution. Hopefully this will be of some benefit for novices in the community who can see that matrix indices can be made dynamic with the use of formulas. This opens a lot of possibilities. Solution involves:
Re-orienting the matrixInput() specifications as shown below (this
is the easy part). Also note the use of multiheader = TRUE and delta = 2 for matrixInput() column specification, so that variables to interpolate are horizontally grouped in pairs of 2 under each scenario heading.
Adjusting the matrix indices where the functions refer to the input matrix, so that matrix index references "dynamically" skip along in steps of 2 columns horizontally. For example in the plotData function below, see matrix indices of [i*2-1] and [1,(i*2-1):(i*2)] for skipping horizontally across the matrix in leaps of 2. This part was a bit tricky for me to figure out but it now works.
Code:
library(shiny)
library(shinyMatrix)
library(dplyr)
library(ggplot2)
interpol <- function(a, b) { # a = periods, b = matrix inputs
c <- rep(NA, a)
c[1] <- b[1]
c[a] <- b[2]
c <- approx(seq_along(c)[!is.na(c)], c[!is.na(c)], seq_along(c))$y # << interpolates
return(c)
}
ui <- fluidPage(
sliderInput('periods','Periods to interpolate:',min=2,max=10,value=10),
matrixInput(
"myMatrixInput",
label = "Values to interpolate paired under each scenario heading:",
value = matrix(c(1, 5), 1, 2, dimnames = list(NULL, c("Scenario 1", "NULL"))),
cols = list(extend = TRUE, delta = 2, names = TRUE, delete = TRUE, multiheader = TRUE),
rows = list(extend = FALSE, delta = 1, names = FALSE, delete = FALSE),
class = "numeric"),
plotOutput("plot")
)
server <- function(input, output, session) {
sanitizedMat <- reactiveVal()
observeEvent(input$myMatrixInput, {
if(any(colnames(input$myMatrixInput) == "")){
tmpMatrix <- input$myMatrixInput
colnames(tmpMatrix) <- paste("Scenario", trunc(1:ncol(input$myMatrixInput)/2+1))
updateMatrixInput(session, inputId = "myMatrixInput", value = tmpMatrix)
}
sanitizedMat(na.omit(input$myMatrixInput))
})
plotData <- reactive({
lapply(seq_len(ncol(sanitizedMat())/2),
function(i){
tibble(
Scenario = colnames(sanitizedMat())[i*2-1],
X = 1:input$periods,
Y = interpol(input$periods, sanitizedMat()[1,(i*2-1):(i*2)])
)
}) %>% bind_rows()
})
output$plot <- renderPlot({
plotData() %>% ggplot() + geom_line(aes(
x = X,
y = Y,
colour = as.factor(Scenario)
))
})
}
shinyApp(ui, server)
)
I would like to visualize the input of a shinyMatrix using a plotlymesh3d-plot. I was using a for-loop to convert the matrix input into a data frame having 3 columns (x, y and z) - see below. This works when being run outside the shiny app. Unfortunately, I'm stuck with using this for-loop inside a reactive() environment to pass this into plot_ly(). It says "object of type closure is not subsettable". I read, that this error often comes if you don't treat your reactive object as a function (which I did).
I know that I'm a beginner and I don't have much clue about the syntax of a shiny app. Most likely I did a supid mistake :-) But I don't know how to solve this.
Thanks!
library(shiny)
library(shinyMatrix)
ui <- fluidPage( titlePanel("shinyMatrix: Simple App"),
sidebarPanel(width = 6,tags$h4("Data"),
matrixInput("mat",
value = matrix(1:100, 10, 10),
rows = list(names=T, extend = TRUE),
cols = list(names = TRUE))),
mainPanel(width = 6,
plotlyOutput(
"plotly",
width = "100%",
height = "400px",
inline = FALSE,
reportTheme = TRUE
)))
server <- function(input, output, session) {
df <- data.frame(x="", y="", z="")
df <- reactive({
n=1
for(i in 1:nrow(input$mat)){
for(j in 1:ncol(input$mat)){
df[n,1] <- j*laenge
df[n,2] <- i*laenge
df[n,3] <- input$mat[i,j]
n=n+1
}
}
})
output$plotly <- renderPlotly({plot_ly(df(), x=~x, y=~y, z=~z, type="mesh3d")})
}
shinyApp(ui, server)
Main issue is that you used the same name df for both the reactive and the dataframe. Additionally your reactive has to return something to make your code work, i.e. return the dataframe after your for-loops.
server <- function(input, output, session) {
dd <- data.frame(x = NA, y = NA, z = NA)
df <- reactive({
n <- 1
for (i in 1:nrow(input$mat)) {
for (j in 1:ncol(input$mat)) {
dd[n, 1] <- j * laenge
dd[n, 2] <- i * laenge
dd[n, 3] <- input$mat[i, j]
n <- n + 1
}
}
dd
})
output$plotly <- renderPlotly({
plot_ly(df(), x = ~x, y = ~y, z = ~z, type = "mesh3d")
})
}
I have the dataframe below:
col1<-sample(500, size = 500, replace = TRUE)
col2<-sample(500, size = 500, replace = TRUE)
d<-data.frame(col1,col2)
And I create a histogram of this data frame that has click-event activated. When the user clicks on a bar the rows of the dataframe that have the relative value are displayed in a datatable. The problem is that the app works fine with a few values. If for example my dataframe had 5 rows instead of 500 with :
col1<-sample(5, size = 5, replace = TRUE)
col2<-sample(5, size = 5, replace = TRUE)
d<-data.frame(col1,col2)
But with more values the app does not work since the plotly gives a range of values in every single bar instead of a unique value.
library(plotly)
library(shiny)
library(DT)
ui <- fluidPage(
mainPanel(
plotlyOutput("heat")
),
DT::dataTableOutput('tbl4')
)
server <- function(input, output, session) {
output$heat <- renderPlotly({
render_value(d) # You need function otherwise data.frame NN is not visible
p <- plot_ly(x = d$col2, type = "histogram",source="subset") # set source so
# that you can get values from source using click_event
})
render_value=function(NN){
output$tbl4 <- renderDataTable({
s <- event_data("plotly_click",source = "subset")
print(s)
return(DT::datatable(d[d$col2==s$y,]))
})
}
}
shinyApp(ui, server)
You can try this (added code to capture the count). You need to plot a histogram of count and then you can able to get your original data based on click event.
library(plotly)
library(shiny)
library(DT)
library(dplyr)
ui <- fluidPage(
mainPanel(
plotlyOutput("heat")
),
DT::dataTableOutput('tbl4')
)
server <- function(input, output, session) {
output$heat <- renderPlotly({
col1<-sample(500, size = 500, replace = TRUE)
col2<-sample(500, size = 500, replace = TRUE)
d<-data.frame(col1,col2)
d=d %>%
group_by(col2) %>%
mutate(count = n()) # You can programatically add count for each row
render_value(d) # You need function otherwise data.frame NN is not visible
p <- plot_ly(x = d$count, type = "histogram",source="subset")
# You should histogram of count
# set source so that you can get values from source using click_event
})
render_value=function(d){
output$tbl4 <- renderDataTable({
s <- event_data("plotly_click",source = "subset")
print(s)
return(DT::datatable(d[d$count==s$x,]))
})
}
}
shinyApp(ui, server)
Screenshot from the working prototype:
How can we get interactive coordinates(x and y) of multiple histograms in shiny. I have tried this code
#server.R
library(xts)
shinyServer(function(input, output,session) {
output$info <- renderText({
paste0("x=", input$plot_click$x, "\ny=", input$plot_click$y)
})
output$plot<- renderPlot({
set.seed(3)
Ex <- xts(1:100, Sys.Date()+1:100)
df = data.frame(Ex,matrix(rnorm(100*3,mean=123,sd=3), nrow=100))
df<-df[,-1]
par(mfrow = c(2,2))
for(i in names(df)){
hist(df[[i]] , main=i,xlab="x",freq=TRUE,label=TRUE,plot = TRUE)
}
})
})
ui.R
#ui.r
mainPanel(
tabsetPanel(type="tab",tabPanel("plot", plotOutput("plot",click = "plot_click"), verbatimTextOutput("info"))
)
The problem with above code is I get random coordinates of the whole plot like this
x=124.632301932263
y=20.4921068342051
instead I want to get coordinates of individual plots with its corresponding values. For example if I click any place in X1's chart I should get x and y coordinates of that chart . How can I do this?
I originally was going to say that this occurs because the click is governed by the pixels of the plot instead of the data, but I am proved wrong here:
Notice that the x and y coordinates are scaled to the data, as opposed to simply being the pixel coordinates. This makes it easy to use those values to select or filter data.
I instead am going to honestly guess that within a graphics device Shiny can't tell the difference between the individual plots, to which a solution would be to create individual devices for each plot:
ui.R
library(shiny)
shinyUI(
tabsetPanel(type="tab",
tabPanel("plot",
uiOutput("coords"),
uiOutput("plots")
)
)
)
server.R
library(xts)
set.seed(3)
Ex <- xts(1:100, Sys.Date() + 1:100)
df <- data.frame(Ex, matrix(rnorm(100*3, mean = 123, sd = 3), nrow = 100))
cn <- colnames(df)
df <- df[, cn[cn != "Ex"]]
n_seq <- seq(ncol(df))
shinyServer(function(input, output, session) {
output$plots <- renderUI({
plot_output_list <- lapply(n_seq, function(i) {
plotOutput(paste0("plot", i), click = paste0("plot_click", i),
height = 250, width = 300)
})
})
for (i in n_seq) {
output[[paste0("plot", i)]] <- renderPlot({
hist(df[[i]] , main = i, xlab = "x", freq = TRUE, label = TRUE)
})
}
output$coords <- renderUI({
coords_output_list <- lapply(n_seq, function(i) {
renderText({
set <- input[[paste0("plot_click", i)]]
paste0("Plot ", i, ": x=", set$x, "\ny=", set$y)
})
})
})
})
This a functioning shiny app that I found on Stack Overflow
rm(list = ls())
library(shiny)
# Sample Data
area <- seq(from=10,to=100, by=10);peri <- seq(from=2710.1,to=2800.1, by=10)
shape <- seq(from=0.1,to=1, by=0.1);perm <- seq(from=1,to=100, by=10)
my_data <- as.data.frame(cbind(area,peri,shape,perm))
ui = fluidPage(
sidebarPanel(
sliderInput("range", "Select Range",min = 1, max = 10, value = c(2,
5)),width = 4),
mainPanel(tableOutput("view"))
)
server = function(input, output) {
output$view <- renderTable({
test <- my_data[input$range[1]:input$range[2],]
test}, include.rownames = FALSE)
}
}
runApp(list(ui = ui, server = server))
I would like to shorten the dataframe based on the numeric values of a column
I tried changing the line:
mydata$area <- my_data$area[input$range[1]:input$range[2]]
However I realized that this reduces the rows of that column without adjusting the other rows to match the same number of rows. Any ideas on how to reduce the other rows as well?