Related
I want to calculate the distance of the segment between 2 clicked points, i already have a function with that launches a shiny dashboard that allows you to save the clicks and draw a line between the pairs. It is printing the dimension of the image in pixels. Any image can be used changing the image_path.
I want to know if there is a way to select the segments of each pair and calculate the distance between them in pixels and later convert it to cm.
library(shiny)
library(shinydashboard)
library(dplyr)
library(imager)
library(reactable)
click_length <- function(image_path = system.file("example_images", package = "ClickMetrics")){
app <- shinyApp(
ui <- dashboardPage(
skin = 'purple',
dashboardHeader(title = "ClickMetrics"),
dashboardSidebar(disable = TRUE),
dashboardBody(
fluidRow(
box(plotOutput("IMG",
height = 400,
click = "click_plot")),
box(
(selectInput("IMAGE",
"Images:",
list.files(path = image_path,
pattern = ".jpg",
full.names = TRUE,
include.dirs = FALSE)))
),
actionButton("clear","Clear Points"),
reactableOutput("INFO")
)
)
),
server <- function(input, output, session){
# Creating a reactive value that receives image input
img <- reactive({
f <- input$IMAGE
imager::load.image(f)
})
# Store reactive values for coordinates
CLICKS <- reactiveValues(
x = NULL,
y = NULL,
n = NULL,
pair = NULL
)
ns <- session$ns
observeEvent(eventExpr = input$click_plot$x, handlerExpr = { ## Adds the info about clicks
CLICKS$x <- append(CLICKS$x, input$click_plot$x)
CLICKS$y <- append(CLICKS$y, input$click_plot$y)
CLICKS$n <- append(CLICKS$n, length(CLICKS$x))
CLICKS$pair <-
append(CLICKS$pair,
as.integer(ceiling(length(CLICKS$x)/2)))
df <- data.frame(CLICKS$x, CLICKS$y, CLICKS$pair)
df <- split(df, CLICKS$pair)
print(dim(img())) # prints dimensions of the image
})
output$IMG <- renderPlot({
expr = {
img <- img()
par(mar = c(0.5, 0.5, 1.75, 0.5))
plot(img, axes = FALSE)
box(col = 'gray')
mtext(text = input$IMAGE,
side = 3,
line = 0.5,
adj = 0.5,
cex = 1.23)
if (!is.null(CLICKS$x) && length(CLICKS$x) > 0) {
points(x = CLICKS$x,
y = CLICKS$y,
pch = 19,
cex = 0.75,
col = "red")
text(x = CLICKS$x,
y = CLICKS$y,
label = CLICKS$n,
pos = 3)
n_par <- 2 * floor(length(CLICKS$x)/2)
tb_pairs <- cbind(
matrix(CLICKS$x[1:n_par], ncol = 2, byrow = TRUE),
matrix(CLICKS$y[1:n_par], ncol = 2, byrow = TRUE))
segments(x0 = tb_pairs[, 1],
x1 = tb_pairs[, 2],
y0 = tb_pairs[, 3],
y1 = tb_pairs[, 4],
col = "black")
}
}
})
output$INFO <- renderReactable({
df1 <- data.frame(round(CLICKS$x,2), round(CLICKS$y,2), CLICKS$pair)
reactable(df1)
})
observe({ # clear clicked points
if(input$clear>0){
session$reload()
}
})
})
runApp(app)
}
click_length()
I tried some examples using locator, but it does not work inside a shiny dashboard, which i need.
I am trying to create a dashboard in Shiny. I am taking inputs(data frame - df1) from a user and do some prediction and display the results of the prediction as well as a plot of air quality parameters.
Below is the ui code chunk -
########## User interface ############
ui <- dashboardPage(
dashboardHeader(title = "Air Quality Index"),
dashboardSidebar(
selectizeInput(
"City", "Select the City:",
choices = list("Mumbai", "Delhi", "Bengaluru")
),
numericInput("PM2.5", "PM2.5 Levels:", min = 0, max = 1000, value = 50),
numericInput("PM10", "PM10 Levels:", min = 0, max = 1000, value = 50),
numericInput("NO", "NO Levels:", min = 0, max = 1000, value = 50),
numericInput("CO", "CO Levels:", min = 0, max = 1000, value = 50),
numericInput("NO2", "NO2 Levels:", min = 0, max = 1000, value = 50),
numericInput("O3", "O3 Levels:", min = 0, max = 1000, value = 50),
actionButton("submitbutton", "Calculate AQI", class = "btn btn-primary")
),
dashboardBody(
fluidRow(
valueBoxOutput("AQI"),
valueBoxOutput("high_risk_params")
),
fluidRow(
box(title = "Polluting Contents in Air:", solidHeader = TRUE,
width = 12, collapsible = TRUE,
plotlyOutput("param_plot"))
)
))
And the code for server is -
########### Server logic ############
server <- function(input, output, session) {
# Input Data
datasetInput <- reactive({
df1 <- data.frame(
Names= c("City"= input$City,
"PM2.5"= input$PM2.5,
"PM10"= input$PM10,
"NO"= input$NO,
"NO2"= input$NO2,
"CO"= input$CO,
"O3"= input$O3
),
stringsAsFactors = FALSE)
n <- rownames(df1)
input <- data.table::transpose(df1)
colnames(input) <- n
input[,2:7] <- as.numeric(input[,2:7])
predicted <- data.frame(Predicted.AQI=predict(rf_model_new,input))
print(predicted)
})
output$param_plot <- renderPlotly({
df1 <- data.table::transpose(df1, keep.names = "rn")
df1 <- df1[-1,]
print(df1)
plot <- ggplot(df1) +
geom_col(aes(x = rn, y = as.numeric(V1), fill = as.numeric(V1))) +
labs(x = "Air Paramteres", y = "Value") +
theme_gray() +
ylim(0, NA) +
geom_hline(yintercept = 50) +
scale_fill_gradient(low = "green",
high = "red",
limits = c(0, 300),
na.value = "darkred",
name = "Value") +
theme(panel.background = element_rect(fill = "mintcream"),
legend.position = "none")
plot <- ggplotly(plot)
plot
})
output$AQI <- renderValueBox({
valueBox(paste0( "AQI: ",round(predicted,0)),
" ", icon = icon("cloudscale"), color = "blue", width = 10)
})
output$high_risk_params <- renderValueBox({
risk_df <- df1 %>%
filter(df1[,2:7]> 100)
if(nrow(risk_df)>0){
valueBox("Over Safe Limits", HTML(paste0(risk_df$rn, sep= "<br>")),
icon = icon("exclamation-triangle"), color = "red")
}
else{
valueBox("No Hazard", icon = icon("exclamation-triangle"), color = "green")
}
})
}
Now the error showing is -
Warning: Error in data.table::transpose: object 'df1' not found &
Warning: Error in paste0: object 'predicted' not found &
Warning: Error in filter: object 'df1' not found
Attaching screenshot of the errors.
Any help is much appreciated. Thanks!
https://i.stack.imgur.com/4ncQq.png
try to declare df1 var outside the reactive({}) function and make it global across the whole server and then use it below inside the renderPlotly({}) function
Trying to create a ui.r file for showing a Pert Distribution
I got the following error: Error in ui.r: argument "variable" is missing, with no default
The common fix for this that I have seen is to remove unnecessary commas and I believe I have done this.
server <- function(input, output){
BS = function(n, births, cat2, statusmin, statusmode, statusmax, impactmin, impactmode, impactmax){
d1 = births*cat2*rpart(n,statusmin,statusmode,statusmax)*rpart(n,impactmin,impactmode,impactmax)
return(d1)
}
output$plotCall <- renderPlot({
n = input$n
births = input$births
cat2 = input$cat2
statusmin = input$statusmin
statusmode = input$statusmode
statusmax = input$statusmax
impactmin = input$impactmin
impactmode = input$impactmode
impactmax = input$impactmax
gg <- ggplot(data.frame(BS()), aes(x = BS))
gg <- gg + geom_histogram(aes(y = ..density..),color = "black", fill = "white",
binwidth = 2 * IQR(BS) / length(BS)^(1/3))
gg <- gg + geom_density(fill = "steelblue", alpha = 1/3)
gg <- gg + scale_x_continuous(labels = comma)
gg <- gg + theme_bw()
plot(gg, labels = TRUE, conf.level = .8)
}
)
}
ui <- shinyUI(fluidPage(
titlePanel("ROI"),
sidebarLayout(
sidebarPanel(
numericInput('n', 'Number of Simulations', 1000, min = 1, max = 1000, step = 1),
numericInput('birth', 'Number of Births', 6811, min = 1, max = 10000, step = 1),
numericInput('cat2', 'Percentage of Category II Strips', 0.84, min = 0.01, max = 1, step = 0.01),
numericInput('statusmin', '% Status Min', 0.1, min = 0.01, max = 1, step = 0.01),
numericInput('statusmode', '% Status Most Likely', 0.3, min = 0.01, max = 1, step = 0.01),
numericInput('statusmax', '% Status Max', 0.4, min = 0.01, max = 1, step = 0.01),
numericInput('impactmin', '% Impact Min', 0.2, min = 0.01, max = 1, step = 0.01),
numericInput('impactmode', '% Impact Most Likely', 0.4, min = 0.01, max = 1, step = 0.01),
numericInput('impactmax', '% Impact Max', 0.64, min = 0.01, max = 1, step = 0.01)
),
mainPanel(
textOutput("BScall"),
hr(),
tabsetPanel(
tabPanel("Calls", plotOutput("plotCall",width="100%"))
)
)
)
))
shinyApp(ui = ui, server = server)
I am trying to get a histogram of the results of d1.
I've found a couple of issues in this code. As Wil pointed out in the comments, you define BS as a function with several arguments, but when you call BS() you're not assigning any arguments to it.
So, the first change I made was to define a variable called result_d1 that receives the output from BS(n, births, cat2, statusmin, statusmode, statusmax, impactmin, impactmode, impactmax). Then I passed this variable to ggplot:
here: gg <- ggplot(data.frame(result_d1), aes(x=result_d1));
and here:
gg + geom_histogram(aes(y = ..density..),color = "black", fill = "white",
binwidth = 2 * IQR(result_d1) / length(result_d1)^(1/3))
Another issue is that you call input$births but the ID for your numericInput is "birth". I changed this to "births".
Even after these fixes, we have issues with the function rpart, as Wil pointed out as well. I'm not familiar with this function nor its package, but since you said that you want to plot a Pert Distribution I'll use the function dpert from the mc2d package to get the values for the histogram. I don't know if this is exactly what you want, but with a working code that uses this dpert you can make the necessary changes to use the rpart function.
One last thing, I changed scale_x_continuous(labels = comma) to scale_x_continuous(labels = scales::comma).
Here's the full code:
server <- function(input, output){
BS = function(n, births, cat2, statusmin, statusmode, statusmax, impactmin, impactmode, impactmax){
x.status <- seq(statusmin, statusmax, length.out= n)
x.impact <- seq(impactmin, impactmax, length.out= n)
d1 = births*cat2*
dpert(x.status, min=statusmin, mode=statusmode, max=statusmax)*
dpert(x.impact, min=impactmin, mode=impactmode, max=impactmax)
return(d1)
}
output$plotCall <- renderPlot({
n = input$n
births = input$births
cat2 = input$cat2
statusmin = input$statusmin
statusmode = input$statusmode
statusmax = input$statusmax
impactmin = input$impactmin
impactmode = input$impactmode
impactmax = input$impactmax
result_d1 <- BS(n, births, cat2, statusmin, statusmode, statusmax, impactmin, impactmode, impactmax)
gg <- ggplot(data.frame(result_d1), aes(x=result_d1))
gg <- gg + geom_histogram(aes(y = ..density..),color = "black", fill = "white",
binwidth = 2 * IQR(result_d1) / length(result_d1)^(1/3))
gg <- gg + geom_density(fill = "steelblue", alpha = 1/3)
gg <- gg + scale_x_continuous(labels = scales::comma)
gg <- gg + theme_bw()
plot(gg, labels = TRUE, conf.level = .8)
}
)
}
ui <- shinyUI(fluidPage(
titlePanel("ROI"),
sidebarLayout(
sidebarPanel(
numericInput('n', 'Number of Simulations', 1000, min = 1, max = 1000, step = 1),
numericInput('births', 'Number of Births', 6811, min = 1, max = 10000, step = 1),
numericInput('cat2', 'Percentage of Category II Strips', 0.84, min = 0.01, max = 1, step = 0.01),
numericInput('statusmin', '% Status Min', 0.1, min = 0.01, max = 1, step = 0.01),
numericInput('statusmode', '% Status Most Likely', 0.3, min = 0.01, max = 1, step = 0.01),
numericInput('statusmax', '% Status Max', 0.4, min = 0.01, max = 1, step = 0.01),
numericInput('impactmin', '% Impact Min', 0.2, min = 0.01, max = 1, step = 0.01),
numericInput('impactmode', '% Impact Most Likely', 0.4, min = 0.01, max = 1, step = 0.01),
numericInput('impactmax', '% Impact Max', 0.64, min = 0.01, max = 1, step = 0.01)
),
mainPanel(
textOutput("BScall"),
hr(),
tabsetPanel(
tabPanel("Calls", plotOutput("plotCall",width="100%"))
)
)
)
))
shinyApp(ui = ui, server = server)
And the output:
I'm trying to understand how ggvis works in the context of shiny and it's been a real headache. At this point I'm just trying to make something, anything interactive. Ideally I would like to be able to filter data points with sliders and be able to click on sectors and links to zoom and highlight respectively.
Ignoring the entire right bar, how would I be able to implement ggvis?
server.r
options(shiny.maxRequestSize=60*1024^2)
# Option to use scientific notation
options(scipen=999)
library(ggplot2)
library(ggvis)
shinyServer(function(input, output) {
inputData <- try(reactive({
inFile <- input$file1
if(is.null(inFile$datapath)){
return(iris)
}
newData <- read.csv(inFile$datapath, fill=TRUE)
newData
}))
output$choose_histVar <- renderUI({
newData <- inputData()
nameDataNew1<-c("ALL" ,"Earmarks", "Free-Cash")
if(class(nameDataNew1)!="try-error"){
selectInput("histVar", "1. Select Funding", as.list(nameDataNew1),
multiple = FALSE)
}
else{
selectInput("histVar", "1.Select Funding", NULL, multiple = FALSE)
}
})
# Use renderTable() function to render a table
output$summaryTable <- renderTable({ summary( try(inputData()) ) })
output$plot.hist <- renderPlot({
plotHistograms(data=try(inputData()), getCol=input$histVar,
getBin=input$bins)
})
output$plot.bar <- renderPlot({ plotcir(data)})
})
plotcir <- function(data) {
set.seed(999)
n = 1000
df = data.frame(factors = sample(letters[1:8], n, replace = TRUE),
x = rnorm(n), y = runif(n))
data.temp <- as.data.frame(df)
circos.par("track.height" = 0.1)
circos.initialize(factors = df$factors, x = df$x)
circos.track(factors = df$factors, y = df$y,
panel.fun = function(x, y) {
circos.text(CELL_META$xcenter, CELL_META$cell.ylim[2] + uy(5,
"mm"),
CELL_META$sector.index)
circos.axis(labels.cex = 0.6)
})
col = rep(c("#FF0000", "#00FF00"), 4)
circos.trackPoints(df$factors, df$x, df$y, col = col, pch = 16, cex = 0.5)
circos.text(-1, 0.5, "text", sector.index = "a", track.index = 1)
bgcol = rep(c("#EFEFEF", "#CCCCCC"), 4)
circos.trackHist(df$factors, df$x, bin.size = 0.2, bg.col = bgcol, col = NA)
circos.track(factors = df$factors, x = df$x, y = df$y,
panel.fun = function(x, y) {
ind = sample(length(x), 10)
x2 = x[ind]
y2 = y[ind]
od = order(x2)
circos.lines(x2[od], y2[od])
})
##vis <- reactive({})
circos.link("a", 0, "b", 0, h = 0.4)
circos.link("c", c(-0.5, 0.5), "d", c(-0.5,0.5), col = "red",
border = "blue", h = 0.2)
circos.link("e", 0, "g", c(-1,1), col = "green", border = "black", lwd = 2,
lty = 2)
}
ui.r
# Load libraries used in this Shiny App
library(shiny)
library(ggplot2)
library(circlize)
library(ggvis)
library(shinythemes)
shinyUI(fluidPage(
titlePanel(title = h2("The Wall", align="center")),
theme = shinytheme("cyborg"),
sidebarPanel(
fileInput('file1', 'The default dataset is df data. You may choose your own
CSV file'),
sliderInput('file1', 'Mission 1', value = 10, min = 0, max = 100, step = 1,
post = "%"),
sliderInput('file1', 'Mission 2', value = 0, min = 0, max = 100, step = 1,
post = "%"),
sliderInput('file1', 'Mission 3', value = 0, min = 0, max = 100, step = 1,
post = "%"),
sliderInput('file1', 'Mission 4', value = 0, min = 0, max = 100, step = 1,
post = "%"),
sliderInput('file1', 'Mission 5', value = 0, min = 0, max = 100, step = 1,
post = "%"),
uiOutput("choose_histVar"),
uiOutput("choose_xVar"),
uiOutput("choose_yVar"),
uiOutput("choose_cateVar"),
uiOutput("choose_barVar"),
p()
),
mainPanel(
h3('DOS - Augmented decisions'),
tabsetPanel(type="tab",
tabPanel( "Optimal",
plotOutput('plot.bar')
),
tabPanel("Histogram",
h4(checkboxInput("showHideHistograms", "Show/hide histograms",
value=FALSE)),
# Add a conditional panel to plot the histogram only when "Show
histogram" is checked
conditionalPanel(
condition = "input.showHideHistograms",
# Use plotOutput function to plot the output visualization
plotOutput('plot.hist')
)
)
),
p('')
)
))
I would like to adjust Holt Winter's method as a forecasting method via shiny. However I could not manage to plot real and forecasted data. However I get an error which indicates time series has no or less than 2 periods.
Here is the code:
ui.R
require(shiny)
require(ggplot2)
require(forecast)
require(TTR)
shinyUI(pageWithSidebar(
headerPanel("Forecasting Methods"),
sidebarPanel(
h3(strong("Holt's Winter",style = "color:black")),
br(),
sliderInput("h","Number of periods for forecasting:",
min = 1, max = 20, step= 1, value = 4),
sliderInput("alpha","Alpha (Smoothing Parameter):",
min = 0.05, max = 1, step= 0.05, value = 0.01),
sliderInput("beta","Beta (Smoothing Parameter):",
min = 0.05, max = 1, step= 0.05, value = 0.01),
sliderInput("gamma","Gamma (Smoothing Parameter):",
min = 0.05, max = 1, step= 0.05, value = 0.01)),
mainPanel(
tabsetPanel( id="tabs",
tabPanel("Holt's Winter",
value="panel",
plotOutput(outputId = "hw",
width = "900px",height = "400px"),
dataTableOutput(outputId="infoes"))
))))
server.R
require(shiny)
require(ggplot2)
require(forecast)
require(TTR)
shinyServer(function(input, output, session){
set.seed(123)
predset <- reactive({
tmp <- data.frame(time = 1:100, sales = round(runif(100, 150, 879)) )
tmp.mean <- HoltWinters(x=tmp$sales, alpha = , beta = input$beta,gamma=input$gamma)
tmp.pred <- data.frame(predict(tmp.mean,n.ahead = input$h, prediction.interval = TRUE), time = tmp[nrow(tmp), "time"] + 1:input$h)
list(tmp = tmp, tmp.pred = tmp.pred)
})
output$hw <- renderPlot({
tmp <- predset()$tmp
tmp.pred <- predset()$tmp.pred
y <- ggplot(tmp, aes(time, sales)) +
geom_line() +
geom_line(data=tmp.pred, aes(y=upr),color="red") +
geom_line(data=tmp.pred, aes(y=fit),color="blue") +
geom_line(data=tmp.pred, aes(y=lwr),color="red") +
xlab("Days") +
ylab("Sales Quantity")+
ggtitle("title")
y })