I'm trying to link a log scaled noUiSliderInput with a linear scaled numericInput without creating an eternal update loop.
Normally I would stop the update lines with this:
input$Histoslider != log10(input$Threshold_box)
This created some issues with decimals, which I can't seem to fix properly.
The main problem seems to be that noUiSliderInput always rounds its output to 2 decimals, causing the rounding problem for the conversion to 10^ and log10 back and forth
Detailed description:
I have an app where the user can set threshold filters in 2 ways:
1: type the number in a numericInput in un-transformed numbers
or
2: by changing the bar on a vertical noUiSliderInput.
The noUiSliderInput however is expressed as log10 numbers, as it is lined up with a plot of the data on log10 scale. so if the plot runs from 10^-1 to 10^4.5, the slider has values running from -1 to 4.5
The numericInput and noUiSliderInputare linked, so change one should update the other.
This created a lot of difficulty with decimals. The numericInput has to be restricted in the app to 2 decimals. So to do that I add some transformation, rounding and transformation back again to get matching numbers.
I can get it to work for a normal sliderInput, but somehow not for a noUiSliderInput, eventhough they should spit out the same format of data.
The reason I have to stick with a noUiSliderInput is because I need a slider on both the x and y axis of the plot.
Try to type 1256 in the numericInput to see an example of the problem
The app:
# install.packages("devtools")
devtools::install_github("dreamRs/shinyWidgets")
library(shiny)
library(shinyWidgets)
# function to see how many decimal places we need
decimalplaces <- function(x) {
if ((x %% 1) != 0) {
deci <- nchar(strsplit(sub('0+$', '', as.character(x)), ".", fixed=TRUE)[[1]][[2]])
if(deci >2) { deci <- 2}
return(deci)
} else {
return(0)
}
}
# starting values for the sliders
minval <- round(-1, digits = 6)
maxval <- round(4.5, digits = 6)
ui <- fluidPage(
tags$br(),
fluidRow(
column(3,
div(numericInput("Threshold_box", "Normal value: ", min = 0, max = 100, value = 1, step=0.01), style = "display:inline-block") ),
column(2,
# div(sliderInput( inputId = "Histoslider", label = NULL, min = minval, max = maxval, value = 0, step = 0.000001), style = 'display:inline-block; position:relative')
noUiSliderInput(inputId = "Histoslider", label = NULL, min = minval, max = maxval, tooltips = FALSE, value = 0, step = 0.000001, direction = "rtl", orientation = "vertical", width = "100px", height = "276px")
)))
server <- function(input, output, session) {
#setting decimals to 6 as that seemed to work in the end for a normal sliderInput
values <- reactiveValues( transformDecimal = 2)
observeEvent(input$Threshold_box, {
if(!is.na(input$Threshold_box)) { values$transformDecimal <- decimalplaces(input$Threshold_box)
if(input$Histoslider != log10(input$Threshold_box)) {
newval <- log10(input$Threshold_box)
# updateSliderInput(session, 'Histoslider', value = newval)
updateNoUiSliderInput(session, 'Histoslider', value = newval)
}}}, ignoreInit = T)
observeEvent(input$Histoslider, {
## next three lines are to get matching set between a 2 decimal numer and the log value
sliderFull <- 10^input$Histoslider
sliderRound <- round(sliderFull, digits = values$transformDecimal)
sliderLog <- log10(sliderRound)
updateSliderInput(session, 'Histoslider', value = sliderLog)
if(sliderLog != log10(input$Threshold_box)) {
updateNumericInput(session, 'Threshold_box', value = round(10^sliderLog, digits = values$transformDecimal))
}
}, ignoreInit = T)
}
shinyApp(ui, server)
Related
Intro:
I have a list of 40 variables that each has 2000 entries, I am working in R Shiny in order to try automatically divide the data into 3 bins based the value at 1/3 of the data and 2/3 of the data.
Each variable has a range between -10 and 10.
UI code below:
selectInput("variable","Select your variable",choices = sort(colnames(train))),noUiSliderInput(inputId = "bins", label = "Choose bin width", min = -10, max = 10, value = c(NULL,NULL), orientation = "horizontal", margin = 1, width = 10000, color = "#68228B")
Server code:
ordered_data <- reactive({
sort_test <- c(joined_adw[,input$variable])
sort_test <- as.numeric(unlist(sort_test))
sort_test <- sort(sort_test)
})
eventReactive(
input$variable,{
updateNoUiSliderInput(session = session, inputId = "bins", value = c(ordered_data()[667], test()[1334]))
})
}
I know that there are other ways of doing this, but I need the slider in the report sheet.
Any help would be massively appreciated, as I have been trying to do this for a while, and each time I try it, the slider disappears when I use an update call.
I am creating a shiny app where I would like to offer users two ways to give two input values: Either directly via two input sliders, or via two data tables on which the app performs some computation with two values as output.
The output values depend on each other, and should sum to one.
I get both these methods working separately: Slider 1 is updated when the value of slider 2 is changed and vice versa, and I managed to compute the output values using the data (See MWE).
Now I would like to combine them such that each slider is updated when a.) the other slider is updated manually; or b.) the data table is changed.
I would like to use these updated slider values for computations in another function.
Any suggestions to change the value of updateSliderInput() when two sources of input are available?
MWE:
library(shiny)
library(rhandsontable)
#### Initialization ####
# Initial data
datA <- datB <- data.frame(success=c(1,1,2), failure=c(1,1,2), total=c(2,2,4))
colnames(datA) <- colnames(datB) <- c(expression(x[T*","*2]==1), expression(x[T*","*2]==0)," " )
rownames(datA) <- rownames(datB) <- c(expression(x[T*","*1]==1), expression(x[T*","*1]==0)," " )
# Dummy function to perform some computation on input data
ComputeWeights <- function(datA,datB){
c(sum(datA)/sum(datA,datB),sum(datB)/sum(datA,datB))
}
#### Server ####
server <- shinyServer(function(input, output, session) {
# Allow users to provide slider input via data table
prevA <- reactive({datA})
prevB <- reactive({datB})
changeA <- reactive({
if(is.null(input$hotA)){return(prevA())}
else{
datA <- as.data.frame(hot_to_r(input$hotA))
datA[c(1,2),3] <- rowSums(datA[c(1,2),c(1,2)])
datA[3,c(1,2)] <- colSums(datA[c(1,2),c(1,2)])
datA[3,3] <- sum(datA[c(1,2),3])
datA
}
})
changeB <- reactive({
if(is.null(input$hotB)){return(prevB())}
else{
datB <- as.data.frame(hot_to_r(input$hotB))
datB[c(1,2),3] <- rowSums(datB[c(1,2),c(1,2)])
datB[3,c(1,2)] <- colSums(datB[c(1,2),c(1,2)])
datB[3,3] <- sum(datB[c(1,2),3])
datB
}
})
output$hotA <- renderRHandsontable({rhandsontable(changeA(), width=375,
rowHeaders=c(expression(x[T*","*2]==1), expression(x[T*","*2]==0)," " ),
colHeaders=c(expression(x[T*","*1]==1), expression(x[T*","*1]==0)," " )) %>%
hot_table(rowHeaderWidth=50) %>%
hot_cols(colWidths = c(50,50,50), format="0", allowInvalid=FALSE)%>%
hot_col(3, readOnly=TRUE)%>%
hot_row(3, readOnly=TRUE)})
output$hotB <- renderRHandsontable({rhandsontable(changeB(), width=375,
rowHeaders=c(expression(x[T*","*2]==1), expression(x[T*","*2]==0)," " ),
colHeaders=c(expression(x[T*","*1]==1), expression(x[T*","*1]==0)," " )) %>%
hot_table(rowHeaderWidth=50) %>%
hot_cols(colWidths = c(50,50,50), format="0", allowInvalid=FALSE)%>%
hot_col(3, readOnly=TRUE)%>%
hot_row(3, readOnly=TRUE)})
# Slider updated with input from slider
observe({
updateSliderInput(session, "w2", value = 1-input$w1,
min = 0, max = 1, step=0.01)
})
observe({
updateSliderInput(session, "w1", value = 1-input$w2,
min = 0, max = 1, step=0.01)
})
output$weights <- renderPrint({
ComputeWeights(changeA(),changeB())
})
})
#### UI ####
ui <- shinyUI(fluidPage(
# First input source: sliders
sidebarLayout(sliderInput("w1", "W1",
min = 0, max = 1, value = 0.5, step=0.01),
sliderInput("w2", "W2",
min = 0, max = 1, value = 0.5, step=0.01)),
mainPanel(
# Second input source: data
rHandsontableOutput("hotA", width="100%"),
rHandsontableOutput("hotB", width="100%"),
textOutput("weights")))
)
shinyApp(ui=ui, server=server)
Would it be possible to just add an observe for changeA and changeB which are reactive?
observe({
wts <- ComputeWeights(changeA(),changeB())
updateSliderInput(session, "w1", value = wts[1], min = 0, max = 1, step=0.01)
updateSliderInput(session, "w2", value = wts[2], min = 0, max = 1, step=0.01)
})
Then you could set the slider input to each value of your returned vector from ComputeWeights.
Let me know if this is what you had in mind.
I am having some trouble with creating plots on eventReactive. I have a source code for inside event reactive, and I am trying to make multiple plots. I am a little unsure how to make multiple plots, so I tried to make one into a plot. However, I am still having trouble with this.
My ui and server are
library(shiny)
library(lpSolve)
ui <- fluidPage(
mainPanel(
tabsetPanel(
tabPanel("Information required for the model",
sliderInput("Reservoirs", label = h3("Total Number of Reservoirs"),
min = 1, max = 25,
value = 10),
sliderInput("Municipalities", label = h3("Total Number of Municipalities Served by the Reservoirs"),
min = 1, max = 150,
value = 15),
sliderInput("Time", label = h3("Total Number of Months for Future Decision"),
min = 0, max = 60,
value = 0)
),
tabPanel("Summary of csv files",
actionButton("Run_Model", "Run Model")),
tabPanel("Results",
plotOutput("plot_ipsita"),
img(outfile)
)
)))
server <- function(input, output) {
running_code<-eventReactive(input$Run_Model, {
source("Source_code.R", local=TRUE)
outfile <- tempfile(fileext = '.png')
png(outfile,width=30,height=nR*3,units = "in",res=200)
par(mfrow=c(ceiling(nR)/2, 2))
for (i in 1:nR){
hist(abcd[i,1,1])
}
dev.off()
plot((colSums(abcd[1,,])),type="l",ylab="Withdrawal [mio m3]",xlab = "months",col=1,lwd=3,lty=1)
abline(h=130, col = 2,lwd=3,lty=3)
abline(h=205, col=3, lwd=3,lty=4)
legend("topleft", c("","All Reservoirs","Import","Failure"), col = c(0,1,2,3),pt.cex=0.5,lty=1:4,lwd=3, cex=0.75,bty="n")
title(paste0("Withdrawals from reservoirs and imports and failure for % initial storage" ), cex.main=1)
})
output$plot_ipsita <- renderPlot({
running_code()
})
}
shinyApp(ui = ui, server = server)
And my source code is
nR<-input$Reservoirs
nM<-input$Municipalities
nT<-input$Time
abcd<-array(data=0, c(nR,nM,nT))
for (i in 1:nR){
abcd[i,,]<-(1+i)*55
}
My actual code is a lot more complicated, so I tried to simplify it to test with this one, and it does not seem happy. Nothing is running. However, if I try to run it as a regular R code, I am able to get all the results.
Please help!!!
The mistake in your code is in your ui where your sliderInput Time has a default value 0. This causes the following loop to fail not assigning any value to array abcd:
for (i in 1:nR){
abcd[i,,]<-(1+i)*55
}
Hence, colSums(abcd[1,,]) dos not have the value due to which it fails.
If you change the sliderInput("Time", label = h3("Total Number of Months for Future Decision"), min = 0, max = 60, value = 0) to sliderInput("Time", label = h3("Total Number of Months for Future Decision"), min = 0, max = 60, value = 2) your code creates a graph as follows:
Hope it helps!
I am trying to make a Shiny app to do calculations as in [this pape
There are 3 sorts of calculation,called "calcprior", "calcpval" and "calcFPR".
Which calculation is to be done is chosen by radioButton. Each calculation requires different inputs. The inputs are placed in conditionalPanels. The correct names appear in thec onditionalPanel, but the numerical values aren't passed to the server, e.g. input$pval does not have the value entered in the numericInput in the conditional panel.
In contrast the value of nsamp, needed for all 3 calculations, is passed correctly to the server.
I'm a beginner at Shiny, so I hope that someone can explain what's going wrong. Not being able to see the values of variables makes debugging a million times harder than in regular R.
sidebarLayout(
sidebarPanel(
radioButtons("calctype", "Choose calculation:",selected = "calcFPR",
choices = c(
"prior (for given FPR and P val)" = "calcprior",
"P value (for given FPR and prior)" = "calcpval",
"FPR (for given P value and prior)" = "calcFPR")),
conditionalPanel(
condition = "input.calctype == 'calcprior'",
numericInput("pval", label = h5("observed P value"), value = 0.05, min
= 0, max = 1),
numericInput("FPR", label = h5("false positive risk"), value = 0.05,
min = 0, max = 1)
),
conditionalPanel(
condition = "input.calctype == 'calcpval'",
numericInput("FPR", label = h5("false positive risk"), value = 0.05,
min = 0, max = 1),
numericInput("prior", label = h5("prior probability of real effect"),
value = 0.5, min = 0, max = 1)
),
conditionalPanel(
condition = "input.calctype == 'calcFPR'",
numericInput("pval",label = h5("observed P value"),value = 0.05, min =
0, max = 1),
numericInput("prior", label = h5("prior probability of real effect"),
value = 0.5, min = 0., max = 1.)
),
inputPanel(
numericInput("nsamp",label = h5("Number in each sample"), step = 1,
value = 16, min = 2)
),
mainPanel(
(I also need to work out how to use the calctype to direct the server to the appropriate block of R code.)
Here is a working example for you:
library(shiny)
ui <- fluidPage(
titlePanel("|Species Table"),
sidebarLayout(
sidebarPanel(
radioButtons("calctype", "Choose calculation:",selected = "calcFPR",
choices = c(
"prior (for given FPR and P val)" = "calcprior",
"P value (for given FPR and prior)" = "calcpval",
"FPR (for given P value and prior)" = "calcFPR")),
uiOutput("test1"),
uiOutput("test2"),
inputPanel(
numericInput("nsamp",label = h5("Number in each sample"), step = 1,
value = 16, min = 2)
)),
mainPanel(textOutput("text1"),
textOutput("text2"))
))
server <- function(input, output) {
test <- reactive({
if(input$calctype == 'calcprior'){
label1 <- paste("observed P value")
label2 <- paste("false positive risk")
}else if(input$calctype == 'calcpval'){
label1 <- paste("false positive risk")
label2 <- paste("prior probability of real effect")
}else{
label1 <- paste("observed P value")
label2 <- paste("prior probability of real effect")
}
list(label1 = label1, label2 = label2)
})
output$test1 <- renderUI({
numericInput("test1", label = h5(test()$label1), value = 0.05, min = 0, max = 1)
})
output$test2 <- renderUI({
numericInput("test2", label = h5(test()$label2), value = 0.05, min = 0, max = 1)
})
output$text1 <- renderText({
input$test1
})
output$text2 <- renderText({
input$test2
})
}
shinyApp(ui = ui, server = server)
you do not need so many conditionalPanels, i have noticed in your code that the only thing that changes is the label of numericInput according to choosen calculation type. Therefore in this case i have used if...else... statement in the server to change the label of two `numericInputs (test1 and test2) with choosen calculation type.
Furthermore i have printed out the output of the numericInput `s (text1 and text2) to show you that the user input is acctually passed to server and can be further used in the calculations.
My data is a matrix with a variable number of columns. Also , the range of values within the matrix is variable, too.
I want to build a variable number of sliderInput, each corresponding to one column in the matrix.
The higher limit of each slider should correspond to the maxRange within the matrix.
Any suggestion how to do it in one shot?
lapply(1:ncol, function(i) {
sliderInput(
paste0('a', i),
paste0('SelectA', i),
min = min(c(1:maxRange)),
max = max(c(1:maxRange)),
value = c(1, maxRange),
step =1
)
}
)
I had broadly similar problem when I wanted to create a set of input elements corresponding to values derived from the data set (min, max list of options, etc.). Broadly speaking, I would source all the required data via global.R and then reference the concepts in the elements, so on the lines of getting min/max in a slider:
global.R
# Get dates for the slider
## Delete pointless month
dta.nom$DATE_NAME <- sub("February ", replacement = "", x = dta.nom$DATE_NAME)
## Convert to number and get min/max
dta.nom$DATE_NAME <- as.numeric(x = dta.nom$DATE_NAME)
yr.min <- min(dta.nom$DATE_NAME)
yr.max <- max(dta.nom$DATE_NAME)
Then in the slider
ui.R
# Select the dates for the data
sliderInput("sliderYears", label = h5("Years"), min = yr.min,
max = yr.max, value = c(2000, 2010), sep = "",
step = 1, animate = FALSE),
Full code is on GitHub. I'm not sure if I understood you correctly but if you are interested in dynamically connecting elements of your interface in Shiny then you can make use of the updateSelectInput. Any other problems with respect to referencing the data should be solvable with use of global code and referencing the values in your interface elements.
In case someone might bump into the same problem, here is my solution:
ui.R
....
sidebarPanel(
selectInput(
inputId = "dataName",
label = "Select your data",
choices = c("data1", "data2", "data3", "data4")
),
uiOutput(outputId = "sliders")
),
.....
server.R
.....
output$sliders <- renderUI({
numSliders <- numCols(input$dataName)
lapply(1:numSliders, function(i) {
sliderInput(
inputId = paste0('column', i),
label = paste0('Select the range for column ', i),
min = min(selectRange(input$dataName)),
max = max(selectRange(input$dataName)),
value = c(min(selectRange(input$dataName)), max(selectRange(input$dataName))),
step =1)
})
})
........
selectRange is a another function in global.R:
global.R
selectRange <- function(x){
if(x == "data1"){choices = c(1:100)}
if(x == "data2"){choices = c(1:50)}
if(x == "data3"){choices = c(1:75)}
if(x == "data4"){choices = c(1:150)}
return(choices)
}