ShinyApp - reactive inferno - shiny

I have two input variables, and changing one will cause the change of the other one.
Further to that, if the value of input is outside limits it should default to min (if below) or max (if above) value.
All works fine as long as up and down arrows are being used.
The moment I am typing value 1 in Input1 it goes crazy.
Same if I am deleting Input2, even before I am typing anything...
I am aware that it must have something to do with reactive values, but can not fix it...
Any suggestion will be very much appreciated!
library(shiny)
ui <- fluidPage(
fluidRow(
uiOutput("Input1"),
numericInput("Input2", "Input 2",
min = 50, max = 150,
value = 100, step = 1)),
tableOutput("result")
)
#########################################################
server <- function(input, output, session) {
global <- reactiveValues(numVal = 10, numMin = 5, numMax = 15)
numVal <- reactive({
if(!is.null(input$Input1)){
if(input$Input1 < global$numMin) return(global$numMin)
if(input$Input1 > global$numMax) return(global$numMax)
return(input$Input1)
}else{
return(global$numVal)
}
})
output$Input1 <- renderUI(numericInput("Input1", "Input 1",
min = global$numMin, max = global$numMax,
value = numVal(), step = 0.1))
# when Input1 change, update Input2
observeEvent(input$Input1, {
updateNumericInput(session = session,
"Input2",
value = format(round(input$Input1*10, 0), nsmall = 0))
})
# when Input2 change, update Input1
observeEvent(input$Input2, {
updateNumericInput(session = session,
"Input1",
value = format(round(input$Input2*0.1, 1), nsmall = 1))
})
inputdata <- reactive({
data <- data.frame(Coef = as.numeric(input$Input1))
data
})
output$result <- renderTable({
data = inputdata()
resultTable = as.character(round((data$Coef + 10)*100, digits=2))
resultTable
})
}
#########################################################
shinyApp(ui, server)

You are on the brink of getting into a race condition:
Input 1 changes Input 2 changes Input 1 changes Input 2...
So foremost you should reconsider your design. You can use debounce / throttle to avoid some of the race consition by telling Shiny not too fire too quickly and as the updates are bijective you may achieve what you want, but I would really think about your design b/c these circle dependencies are almost never a good idea.
Having said that here is a solution which behaves better (N.B. I removed the dynamic rendering of the second input element as it has nothing to do wiht the problem at hand). It is not perfect, b/c you will eventually end up in a racing condition, but you can soften this situation by playing w/ the debouncing factors.
library(shiny)
ui <- fluidPage(
fluidRow(
numericInput("Input1", "Input 1",
min = 5, max = 15, value = 10, step = .1),
numericInput("Input2", "Input 2",
min = 50, max = 150,
value = 100, step = 1)),
tableOutput("result")
)
server <- function(input, output, session) {
## debounce both input, i.e. they are firing onyl if no change within 1sec happens
## c.f. ?debounce
getI1 <- reactive(input$Input1) %>%
debounce(1000)
getI2 <- reactive(input$Input2) %>%
debounce(1000)
observeEvent(input$Input1, {
updateNumericInput(session = session,
"Input2",
value = format(round(getI1() * 10, 0), nsmall = 0))
})
observeEvent(input$Input2, {
updateNumericInput(session = session,
"Input1",
value = format(round(getI2() * 0.1, 1), nsmall = 1))
})
inputdata <- reactive({
data <- data.frame(Coef = as.numeric(input$Input1))
data
})
output$result <- renderTable({
data = inputdata()
resultTable = as.character(round((data$Coef + 10)*100, digits=2))
resultTable
})
}
shinyApp(ui, server)

Related

How can I print tops (print[:]) according user preference with slide bar?

How can i run a r shiny app, which print the top features based on user's choice?
I tried the following but I want the user to select, not putting it manually the top 3 for example
library(KEGGgraph)
library(xml2)
library(Rgraphviz)
ui <- fluidPage(
sidebarLayout(
sliderInput("range",
label = "Range of interest:",
min = 0, max = 10, value = c(0, 100))
),
mainPanel(
tabsetPanel(type = "tabs",
tabPanel("Plots", plotOutput(outputId="genePlot", width = 1300, height=900)),
tabPanel("Edges", verbatimTextOutput("out_tops")),
tabPanel("Compounds", tableOutput("out_compounds")))
)
)
)
server <- function(input, output) {
output$out_tops <- renderPrint({
mapkGall <- parseKGML2Graph(read_xml(sprintf("%s.xml", input$geneInput)), genesOnly=FALSE)
mapkGsub <- subGraphByNodeType(mapkGall, "gene")
graphs <- list(mapk=mapkGsub, wnt=mapkGall)
merged <- mergeGraphs(graphs)
merged
outs <- sapply(edges(merged), length) > 0
ins <- sapply(inEdges(merged), length) > 0
ios <- outs | ins
mapkGoutdegrees <- sapply(edges(mapkGall), length)
mapkGindegrees <- sapply(inEdges(mapkGall), length)
topouts <- sort(mapkGoutdegrees, decreasing=T)
topins <- sort(mapkGindegrees, decreasing=T)
if(require(org.Hs.eg.db)) {
top_nodes_out <- translateKEGGID2GeneID(names(topouts))
tmp <- c()
for (i in top_nodes_out) {
if (is.na(mget(sprintf("%s",i), org.Hs.egSYMBOL, ifnotfound = NA))) {
tmp <- append(tmp,sprintf("%s",i))
}
else {
tmp <- append(tmp,mget(sprintf("%s",i), org.Hs.egSYMBOL))
}
}
nodesNames_outs <- sapply(tmp, "[[",1)
} else {
nodesNames_outs <- names(topouts)
}
how can I let the user specify the printings by the slider bar?
names(nodesNames_outs) <- names(topouts)
print("top genes with out connections")
print(nodesNames_outs[1:3]) ### Here like something for the slider bar print[:,sliderbar$input]
I would like not to print manually the top 3 but the user to select how many he wants. the code should sort the top genes and print them accordingly when user uses the slidebar
Can you please suggest something?

reactive environment within reactiveValues (RShiny)

I am trying to build a matrix with reactive dimensions that I want to update using an observeEvent expression. My idea was the following:
First, I am creating a reactiveValues object with a matrix of dimensions input$length (--> reactive) and input 0. Then I am using observeEvent with actionButton to trigger an update in the matrix. This entails updating a specific cell in the matrix, indicated by a reactive index vector (ind()), with a reactive value (value()).
I understand the problem: within mat = ... I cannot use another reactive expression, however I don't have an alternative solution and would very much appreciate any input on this.
Thanks in advance!
Kind regards,
Julian
ui <- fluidPage(
numericInput("length", "Dimensions of the matrix", value = 5),
numericInput("a", "value for a", value = 2),
numericInput("b", "value for b", value = 2),
numericInput("ind1", "value for index vector 1", value = 1),
numericInput("ind2", "value for index vector 2", value = 1),
actionButton("go", "Update"),
tableOutput("matrix")
)
server <- function(input, output) {
### Calculate the value that will be used for the update
value <- reactive(
mean(rbeta(100, input$a, input$b))
)
### Create a reactive index vector used to determine the position of the cell in the matrix
ind <- reactive(
c(input$ind1, input$ind2)
)
### Create reactiveValues matrix with dimensions specified in length
beta.matrix <- reactiveValues(
mat = matrix(0, input$length, input$length)
)
### Update matrix at positon ind with new value
observeEvent(input$go, {
beta.matrix$mat[ind()[1], ind()[2]] <- value()
}
)
### Render matrix
output$matrix <- renderTable({
mat <- beta.matrix$mat
mat
})
}
# Run the application
shinyApp(ui = ui, server = server)
I think you'll need two reactive "stages" here.
initialise an empty matrix when the dimensions change
react on changes to the content of the matrix
Please check the following:
library(shiny)
ui <- fluidPage(
numericInput("length", "Dimensions of the matrix", value = 5),
numericInput("a", "value for a", value = 2),
numericInput("b", "value for b", value = 2),
numericInput("ind1", "value for index vector 1", value = 1),
numericInput("ind2", "value for index vector 2", value = 1),
actionButton("go", "Update"),
tableOutput("matrix")
)
server <- function(input, output) {
### Calculate the value that will be used for the update
value <- reactive(mean(rbeta(100, input$a, input$b)))
### Create a reactive index vector used to determine the position of the cell in the matrix
ind <- reactive(c(input$ind1, input$ind2))
beta.matrix <- reactiveValues(mat = NULL)
beta.matrix.ini <- reactive({
mat = matrix(0, input$length, input$length)
})
observe({
beta.matrix$mat <- beta.matrix.ini()
})
### Update matrix at positon ind with new value
observeEvent(input$go, {
beta.matrix$mat[ind()[1], ind()[2]] <- value()
})
### Render matrix
output$matrix <- renderTable({
mat <- beta.matrix$mat
mat
})
}
# Run the application
shinyApp(ui = ui, server = server)

how to manipulate dataframe in R shiny app

Please I need assistant concerning a shiny code. I want to manipulate a data frame input by separating them into column vector for computation but I keep getting this error
Warning in <reactive>(...): NAs introduced by coercion
the code is as follows
library(shiny)
ui <- fluidPage(
# dataset
data <- data.frame(e1 = c(3, 7, 2, 14, 66),
e2 = c(2, 16, 15, 66, 30),
n1 = c(18, 25, 45, 62, 81),
n2= c(20, 30, 79, 64, 89))
# Application title
titlePanel("Demo"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
# Input: Upload file
fileInput(inputId = 'file', label = 'upload the file')
),
# Display Output
mainPanel(
uiOutput("final")
)
)
)
# Define server logic required to draw a histogram
server <- function(input, output) {
# separating the dataframe into 4 column vectors
e1 <- reactive(as.numeric(input$file[,1]))
e2 <- reactive(as.numeric(input$file[,2]))
n1 <- reactive(as.numeric(input$file[,3]))
n2 <- reactive(as.numeric(input$file[,4]))
# File Upload function
data <- reactive({
file1 <- input$file
if(is.null(file1)){return()}
read.table(file = file1$datapath, sep = ',', header = TRUE)
})
output$result <- renderUI({
y <- (e1()/n1()) - (e2()/n2())
lg_y <- log(y)
v2 <- ((n1() - e1())/e1() * n1()) + ((n2() - e2())/e2() * n2())
w <- 1/v2
w1 <- sum(w)
w2 <- sum(w^2)
c <- w1 - (w2/w1)
s2 <- w * lg_y
ybar <- sum(s2)/sum(w)
Q <- sum(w*((lg_y - ybar)^{2}))# Cochrane homogeneity test statistic
Q.pval <- reactive(pchisq(Q, k() - 1,lower.tail = FALSE))
Isqd <- max(100*((Q-(k()-1))/Q),0)
})
}
# Run the application
shinyApp(ui = ui, server = server)
I have searched almost every question on this forum and haven't seen where the question was answered. please I look forward to your help
Still can't run the code above because you don't define function k(). Also FYI, your renderUI is set for "result" but your uiOutput is set for "final".
You get the warning Warning in <reactive>(...): NAs introduced by coercion because your true data set probably includes a non-numeric in it. I did not get any issues with the data set you provided above.
There are a couple ways forward:
1) Write a function to remove all non-numerics before you process the data. See here for a few examples.
2) Just keep the warning, it is a warning after all so it won't stop your code from running. Currently it turns your non-numerics into NA
3) Use suppressWarnings() but that is usually not recommended.
I do have a suggestion to clean up your code though:
# File Upload function
data <- reactive({
file1 <- input$file
if(is.null(file1)){return()}
read.table(file = file1$datapath, sep = ',', header = TRUE, stringsAsFactors = FALSE)
})
# separating the dataframe into 4 column vectors
e1 <- reactive(as.numeric(data()[,1]))
e2 <- reactive(as.numeric(data()[,2]))
n1 <- reactive(as.numeric(data()[,3]))
n2 <- reactive(as.numeric(data()[,4]))

R Shiny dq_render_handsontable Error when adding columns and trying to Edit new columns' cells

I get an error while using shiny dq_render_handsontable which I guess it's a bug of the dq_shiny package. I would appreciate if anyone could know any work around.
I am trying to interactively update a table via an action button ("Generate" in the code below). The tables which I am trying to switch among, have different number of columns. All works up to the display of the new table, i.e., once I click on "Generate" I can see the new table with additional columns. BUT the problem is that once I try to edit the cells of the data frame with a more columns after editting the first one with less columns, the following error appear:
Warning: Error in [<-.data.frame: new columns would leave holes after existing columns
I guess that is certainly a bug of dq_render_handsontable that doesn't recognize the new columns added to handsontable. Anyone knows a workaround? Maybe refreshing the table before showing a new data frame with more columns?
I attach the peice of the code to reproduce the error:
library(shiny)
library(rhandsontable)
library(dqshiny)
library(rlang)
ui = fluidPage(
dq_handsontable_output("InputTable", 9)
,
# actionButton("render", "Render HoT"),
actionButton("simulationInput_2", "Generate"),
fluidRow(id="bigRow", class="hidden",
style="height:100vh;background:#ff8f00;")
)
server = function(input, output) {
hw <- c("Hello", "my", "funny", "world!")
data1 <- data.frame(A=hw, B=hw[c(2,3,4,1)], C=1:4, D=Sys.Date() - 0:3,
A2=hw, B2=hw[c(2,3,4,1)], C2=1:4, D2=Sys.Date() - 1:4,
stringsAsFactors = FALSE)
hw <- c("Hello", "my", "funny", "world!")
data2 <- data.frame(A=hw, B=hw[c(2,3,4,1)], C=1:4, D=Sys.Date() - 0:3,
# A2=NA, B2=NA, C2=NA, D2=NA,
stringsAsFactors = FALSE)
cont = 0
observeEvent(input$simulationInput_2, {
cont <<- cont+1
print(cont)
if(mod(cont,2)==0){
data <- data2
}else{
data <- data1
}
renderInputTable(data)
render_hot("InputTable")
})
renderInputTable <- function(data){
dq_render_handsontable(
"InputTable",
data, #"rand",
# filters = F, #c("S", "T", "R", "R"),
filters = rep(NA, ncol(data)),
table_param = list(rowHeaders = NULL, selectCallback = TRUE))
}
observeEvent(input$random_select, toggle("bigRow"))
observeEvent(input$render, render_hot("InputTable"))
}
shinyApp(ui, server)
I could overcome the problem by a trick which is renaming the dq_shiny table ID which is actually a bug of dq_render_handsontable:
library(shiny)
library(rhandsontable)
library(dqshiny)
library(rlang)
library(magrittr)
library(data.table)
ui = fluidPage(
tags$div(id="simulationInputTable_divOutside", style="padding:0px;margin:0px",
tags$div(id="simulationInputTable_divInside1", style="padding:0px;margin:0px",
dq_handsontable_output("InputTable1", 9)),
tags$div(id="simulationInputTable_divInside2", style="padding:0px;margin:0px",
dq_handsontable_output("InputTable2", 9)),
tags$div(id="simulationInputTable_divInside3", style="padding:0px;margin:0px",
dq_handsontable_output("InputTable3", 9))
)
,
# actionButton("render", "Render HoT"),
actionButton("simulationInput_2", "Generate"),
fluidRow(id="bigRow", class="hidden",
style="height:100vh;background:#ff8f00;")
)
server = function(input, output) {
columns <- c(1,2,3,4)
hw <- c("Hello", "my", "funny", "world!")
cont = 0
observeEvent(input$simulationInput_2, {
cont <<- cont+1
data1 <- data.frame(A=hw, B=hw[c(2,3,4,1)], C=1:4, D=Sys.Date() - 0:3,
A2=hw, B2=hw[c(2,3,4,1)], C2=1:4, D2=Sys.Date() - 1:4,
stringsAsFactors = FALSE)
name = paste0("InputTable",cont)
divName = paste0("simulationInputTable_divInside",cont-1)
hide(divName)
dq_render_handsontable(
name,
data1, #"rand",
# filters = F, #c("S", "T", "R", "R"),
filters = rep(NA, ncol(data1)),
table_param = list(rowHeaders = NULL, selectCallback = TRUE))
})
observeEvent(input$random_select, toggle("bigRow"))
observeEvent(input$render, render_hot("InputTable"))
}
shinyApp(ui, server)

To write a csv after the the modaldialogue is closed in shiny

I want to perform some actions like writing in a dataframe post i close the modaldialogue. Consider below example.
obs8<-observe({ req(input$Continue) if(input$password3 > 0 & input$password4 > 0 & (input$password3==input$password4)==TRUE & (is.validpw(input$password3))==TRUE & (is.validpw(input$password4))==TRUE){
showModal(modalDialog(
title=tags$h4(tags$strong("Password Changed Successfully")),
easyClose=FALSE,
footer=modalButton("Close")
))
I am trying to execute below code post the if condition is true and modal is displayed but no luck.
PASSWORD$Passord <- as.character(PASSWORD$Passord)
PASSWORD$Passord[PASSWORD$Passord==pwd] <- input$password3
PASSWORD$Passord <- as.factor(PASSWORD$Passord)
write.csv(PASSWORD,"<PATH>",row.names=FALSE)
I rewrote it as pure Shiny without all the password stuff and it works fine:
ui <- fluidPage(
# Application title
titlePanel("Old Faithful Geyser Data"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
sliderInput("bins",
"Number of bins:",
min = 1,
max = 50,
value = 30)
),
# Show a plot of the generated distribution
mainPanel(
plotOutput("distPlot")
)
)
)
# Define server logic required to draw a histogram
server <- function(input, output) {
output$distPlot <- renderPlot({
# generate bins based on input$bins from ui.R
x <- faithful[, 2]
bins <- seq(min(x), max(x), length.out = input$bins + 1)
# draw the histogram with the specified number of bins
hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
obs8<-observe({
req(input$bins)
if(input$bins > 40){
showModal(modalDialog(
title=tags$h4(tags$strong("Password Changed Successfully")),
easyClose=FALSE,
footer=modalButton("Close")
))
write.csv("1, 2, 1, 2", "<PATH>", row.names = FALSE)
}
})
}
# Run the application
shinyApp(ui = ui, server = server)
There's something wrong with the other stuff you're doing, but I can't tell what it is without a reproducible example