We Keep Coding

How I() function is used to build search bar feature with suggestion in this code any further explanation of the code (last two lines of ui)?

Question
#This shinny app creates a search Bar feature which shows suggestions in real time as soon as user starts #typing in the search bar I don't have clear idea how the last part of the code works:
"
Any explanation of I() functions is used with dropdown and ontype in the last two lines of the "UI" part? is this R code or CSS code? any tutorial reference or readable source for such code will be appreciated.
library(shiny)
ui <- fluidPage(
title = "Search Bar",
fluidRow(
selectizeInput(
inputId = "searchme",
label = "Search Bar",
multiple = FALSE,
choices = c("Search Bar" = "", paste0(LETTERS,sample(LETTERS, 26))),
options = list(
create = FALSE,
placeholder = "Search Me",
maxItems = '1',
onDropdownOpen = I("function($dropdown) {if (!this.lastQuery.length) {this.close(); this.settings.openOnFocus = false;}}"),
onType = I("function (str) {if (str === \"\") {this.close();}}")
)
))
)
server <- function(input, output, session) {
# Show Selected Value in Console
observe({
print(input$searchme)
})
}
shinyApp(ui, server)
I was trying to create search bar and found this code but could not understand the last two lines of the "ui' Part very well. is this R code or CSS code? any tutorial reference or readable source for such code will be appreciated.

Using javascript to alter noUIslider tags in R Shiny error when performing Math.pow(10,x) when x = 0

In an earlier SO question here I have come to a point where I have a noUiSliderInput that gets it's labels updated to a scientific notation format with the help of javascript.
The remaining problem is that the noUiSliderInput jumps to 10 when the input is 0 and it therefore should jump to 1. (10^0 is 1, not 10). I suspect a problem with Math.pow(10,x) is the cause but I am not sure
UPDATE:
The initial problem of the slider jumping to the maximum value has been fixed by changing the javascript code, which now takes values from shiny as input for the min, max and value of the slider.
I have changed the code of the app here in the question to represent the current situation.
#END UPDATE#
The behavior is simulated here with the use of a second sliderInput and numericInput boxes that causes all three values needed for the noUiSliderInput to cahange
In my real app the noUiSliderInput is linked to a plot, and whatever data column the user chooses to plot. So, whatever data the user chooses to plot will require the noUiSliderInput to update it's range. The slider is also linked to a datatable with earlier created settings (a datatable of threshold values for some of the columns in the data), and when the user clicks a datatable entry, it will update the drop down that selects which data is to be plotted (and thus the noUiSliderInput range), as well as at what height the threshold (noUiSliderInput value) should be based on the value in the datatable.
This fires three changes at once, range (i.e. min & max of noUiSliderInput), as well as value of the noUiSliderInput.
I managed to get a dummy app that simulates this behavior working, except the value of the noUiSliderInput gets updated wrong by the current javascript it seems.
The schematic looks like this roughly
Where you can see that clicking on the table will send a value to the noUiSliderInput value, and a parameter name to the parameter selectInput, which then gets the data, sends it to the plot, and send the min, max: range to the noUiSliderInput.
It is build this way because the user can also select parameters (columns) from the selectInput directly (many of which are not in the table of thresholds)
App so far:
library(shiny)
library(shinyWidgets)
library(shinyjs)
js <- function(Min, Max, Start){
sprintf(paste(
"var slider = document.getElementById('Histoslider').noUiSlider;",
"slider.updateOptions({",
" start: %s,",
" range: {min: %s, max: %s},",
" format: wNumb({",
" encoder: function(x){return parseFloat(Math.pow(10,x));}",
" })",
"});",
"var pipsValues = $('.noUi-value');",
"pipsValues.each(function(){$(this).html('10<sup>'+$(this).attr('data-value')+'</sup>')});",
sep = "\n"
), Start, Min, Max)
}
ui <- fluidPage(
useShinyjs(),
tags$br(),
fluidRow(
column(4,
uiOutput('TestSliderOut'),
actionButton(inputId = "UpdateSlider", label = 'Update')
),
column(6,
sliderInput("slider2", label = NULL, min = -5, max = 20, value= c(1, 5), step = 1),
numericInput(inputId = 'SlMin', label = 'Min', value = 1, min = -5, max = 20),
numericInput(inputId = 'SlMax', label = 'Max', value = 5, min = -5, max = 20),
numericInput(inputId = 'SlVal', label = 'Val', value = 3, min = -5, max = 20),
br(),
h5('Update counter'),
verbatimTextOutput(outputId = "updates"),
h5('slider value'),
verbatimTextOutput(outputId = 'ouputval')
)
)
)
server <- function(input, output, session) {
values <- reactiveValues( Counter = 0)
output$TestSliderOut <- renderUI({
noUiSliderInput(
inputId = "Histoslider", label = "Slider vertical:",
min = -2, max = 4, step = 0.01,
value = 0, margin = 100,
pips = list(mode="range", density=2),
orientation = "vertical",
width = "300px", height = "300px", direction = "rtl",
behaviour = "tap"
)
})
observeEvent(input$slider2, {
## simulates the change of multipe parameters of the slider: min, max, value
newvalue <- (input$slider2[2]-input$slider2[1])/2+input$slider2[1]
updateNumericInput(session, inputId = 'SlMin', value = input$slider2[1])
updateNumericInput(session, inputId = 'SlMax', value = input$slider2[2])
updateNumericInput(session, inputId = 'SlVal', value = newvalue)
})
observe({
updateNoUiSliderInput(session, inputId = 'Histoslider', range = c(input$SlMin, input$SlMax), value = input$SlVal)
shinyjs::delay(1, { ## delay the javascript so that it runs after the slider has updated its values
runjs(js(input$SlMin, input$SlMax, input$SlVal)) })
})
output$updates <- renderPrint(values$Counter)
output$ouputval <- renderPrint(input$Histoslider)
observeEvent(input$SlMin, { values$nouiMin <- input$SlMin })
observeEvent(input$SlMax, { values$nouiMax <- input$SlMax })
observeEvent(input$SlVal, { values$nouiVal <- input$SlVal })
observeEvent(input$Histoslider, {
print('changing code')
runjs(js(values$nouiMin, values$nouiMax, values$nouiVal)) ## fires ones on first build of the slider
}, once = TRUE)
}
shinyApp(ui, server)

Hmm that does look strange. It seems to work by using the set method (set the value of the slider) instead of updating the start option:
js <- function(Min, Max, Start){
sprintf(paste(
"var slider = document.getElementById('Histoslider').noUiSlider;",
"slider.updateOptions({",
" range: {min: %s, max: %s},",
" format: wNumb({",
" decimals: 2,",
" encoder: function(x){return parseFloat(Math.pow(10,x));}",
" })",
"});",
"slider.set(%s);",
"var pipsValues = $('.noUi-value');",
"pipsValues.each(function(){$(this).html('10<sup>'+$(this).attr('data-value')+'</sup>')});",
sep = "\n"
), Min, Max, Start)
}
Note that the updateNoUiSliderInput in your code is useless, because the slider is updated by the JS code. So replace
observe({
updateNoUiSliderInput(session, inputId = 'Histoslider', range = c(input$SlMin, input$SlMax), value = input$SlVal)
shinyjs::delay(1, { ## delay the javascript so that it runs after the slider has updated its values
runjs(js(input$SlMin, input$SlMax, input$SlVal)) })
})
with
observeEvent(list(input$SlMin, input$SlMax, input$SlVal), {
runjs(js(input$SlMin, input$SlMax, input$SlVal))
}, ignoreInit = TRUE)

R Shiny Code gets executed multiple times when sending it to Javascript

I have this app:
#
# This is a Shiny web application. You can run the application by clicking
# the 'Run App' button above.
#
# Find out more about building applications with Shiny here:
#
# http://shiny.rstudio.com/
#
library(shiny)
# Define UI for application that draws a histogram
ui <- fluidPage(includeScript("www/script.js"),
# 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(session, 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)
observe({
if(input$bins > 25) {
Message1 = input$bins
session$sendCustomMessage("bla", Message1)
}
})
# draw the histogram with the specified number of bins
hist(x, breaks = bins, col = 'darkgray', border = 'white')
})
}
# Run the application
shinyApp(ui = ui, server = server)
My Oberserver checks if the value is larger than 25. I send the value to Javascript.
$( document ).ready(function() {
Shiny.addCustomMessageHandler("bla", dosomething);
function dosomething(Message1) {
alert(Message1)
}
});
The code works perfectly, BUT every time i change the slider, the code seems to get executed one more time than before. After changing it 2 times, I get 3 alerts for example. Why is that happening and what can I do against it?

The reason this is so broken is that your observe() is inside the renderPlot() function. Generally speaking, observers should not be inside render functions, it's almost always a recipe for very strange undefined behaviours to happen!
Simply moving the observer outside of the render function fixes your problem. This also fixes another problem you didn't mention, that the alert box was actually showing the previous number rather than the current one.
For completeness, this is the correct server code:
server <- function(session, 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')
})
observe({
if(input$bins > 25) {
Message1 = input$bins
session$sendCustomMessage("bla", Message1)
}
})
}

Highlight and Label Line in line chart for Bokeh

I'm dealing with a callback method to create a line chart on the go, given a specific dataframe.
def Total_value(DF):
return pd.DataFrame(pd.DataFrame(DF)['FinalSalePrice'].
groupby(level=0, group_keys=False).
apply(lambda x: x.sort_values(ascending=False).head(15))).reset_index()
def TOP_Item(data):
return np.array(data.ItemCode.value_counts()[data.ItemCode.value_counts() > 20].index)
def figure_creator(arr,l):
# colors = ["#%06x" % random.randint(0,0xFFFFFF) for c in range(len(arr))]
fig = figure(plot_width=1000, plot_height=300,x_axis_type='datetime')
for item in arr:
fig.line(l[l.ItemCode == item].ServicedOn.unique(),l[l.ItemCode == item][np.int(0)], line_width=2)
# fig.add_tools(HoverTool(show_arrow=False,
# line_policy='nearest',
# tooltips=None))
return fig
at the very end I call:
show(figure_creator(TOP_Item(Total_value(SER_2016)),Total_value(SER_2016)))
I want to add a Hovertool which could Highlight the given chart and also display the label for the line.
The DataFrame for these is quite big, hence I can't upload it Here.
But the premise of each of the function is explained below:
Total_value: is used to calculate the total value of money, each unique item in the dataframe has made,sort them, and take only the top 15 items.
Top_Item: is used to calculate which of the 15 items has appeared more than 20 times for a 14 day period in a year(there are 25ish, 14 day periods in a year). Further return the list of the items.
fig_creator: creates a line for each of returned item.
**
Is there a way to create a callback method on the hovertool(commented out) per new line that is being generated ?

I figured it out using select tool. Posting for others who might run into a similar problem.
def figure_creator(arr,l):
# colors = ["#%06x" % random.randint(0,0xFFFFFF) for c in range(len(arr))]
fig = figure(plot_width=1000, plot_height=300,x_axis_type='datetime',tools="reset,hover")
for item in arr:
# dicta
fig.line(l[l.ItemCode == item].ServicedOn.unique(),l[l.ItemCode == item][np.int(0)], line_width=2,alpha=0.4,
hover_line_color='red',hover_line_alpha=0.8)
fig.select(dict(type=HoverTool)).tooltips = {"item":item}
# fig.add_tools(HoverTool(show_arrow=False,
# line_policy='nearest',
# tooltips=None))
return fig
This renders:

Heatmaps on Physical Images (2d or 3d) using .js library for R Shiny App?

I am in the circuit board manufacturing industry, and we measure the temperature at a variety of locations on our circuit boards in an effort to identify if certain components are exceeding their required temperatures.
I have some exposure to .js visualization libraries, RStudio and Shiny. I would like to implement this application into an existing R or ShinyDashboard that I am developing.
What I would like to accomplish is to have a 2d or 3d image of my circuit board, and a heatmap that takes the maximum temperature and shows it on that image. My data sets have columns of temperatures over time for up to 20 different locations.
I know this is a crude description, but I was wondering if anyone has any initial suggestions to accomplish this?
Update1
This is the result of running the first code:
Update2
Here is the sample dataset that I would like to base this heatmap off of.
https://docs.google.com/spreadsheets/d/11I19uQyND7YehKrYd-NPiib4bQSHmHmWENFvausigvU/edit?usp=sharing

You could use ggplot for something like this, for example:
library(grid)
library(ggplot2)
# Download image
library(jpeg)
download.file("http://www.expresspcb.com/wp-content/uploads/2015/06/PhotoProductionPCB_TL_800.jpg","pcb.jpg")
img <- readJPEG("/home/oskar/pcb.jpg")
## Load image, use this if you can't download image
#library(png)
#img <- readPNG(system.file("img", "Rlogo.png", package="png"))
g <- rasterGrob(img, interpolate=TRUE,width=1,height=1)
coords <- data.frame("x"=c(0,1),"y"=c(0,1))
# Simulate data
df <- data.frame("x.pos" = c(runif(200),runif(20,min=0.5,max=0.8)),
"y.pos" = c(runif(200),runif(20,min=0.5,max=0.8)),
"heat" = c(runif(200),runif(20,min=0.7,max=1)))
# Show overlay of image and heatmap
ggplot(data=df,aes(x=x.pos,y=y.pos,fill=heat)) +
annotation_custom(g, xmin=-Inf, xmax=Inf, ymin=-Inf, ymax=Inf) +
stat_density2d( alpha=0.2,aes(fill = ..level..), geom="polygon" ) +
scale_fill_gradientn(colours = rev( rainbow(3) )) +
scale_x_continuous(expand=c(0,0)) +
scale_y_continuous(expand=c(0,0))
# Show where max temperature is
dat.max = df[which.max(df$heat),]
ggplot(data=coords,aes(x=x,y=y)) +
annotation_custom(g, xmin=-Inf, xmax=Inf, ymin=-Inf, ymax=Inf) +
geom_point(data=dat.max,aes(x=x.pos,y=y.pos), shape=21,size=5,color="black",fill="red") +
geom_text(data=dat.max,aes(x=x.pos,y=y.pos,label=round(heat,3)),vjust=-1,color="red",size=10)
The ggplot image part is from here
You can also bin the data manually and overlay it on the image like this (run this part after the script above):
# bin data manually
# Manually set number of rows and columns in the matrix containing sums of heat for each square in grid
nrows <- 30
ncols <- 30
# Define image coordinate ranges
x.range <- c(0,1) # x-coord range
y.range <- c(0,1) # x-coord range
# Create matrix and set all entries to 0
heat.density.dat <- matrix(nrow=nrows,ncol=ncols)
heat.density.dat[is.na(heat.density.dat)] <- 0
# Subdivide the coordinate ranges to n+1 values so that i-1,i gives a segments start and stop coordinates
x.seg <- seq(from=min(x.range),to=max(x.range),length.out=ncols+1)
y.seg <- seq(from=min(y.range),to=max(y.range),length.out=nrows+1)
# List to hold found values
a <- list()
cnt <- 1
for( ri in 2:(nrows+1)){
for ( ci in 2:(ncols+1)){
# Get current segments, for example x.vals = [0.2, 0.3]
x.vals <- x.seg [c(ri-1,ri)]
y.vals <- y.seg [c(ci-1,ci)]
# Find which of the entries in the data.frame that has x or y coordinates in the current grid
x.inds <- which( ((df$x.pos >= min(x.vals)) & (df$x.pos <= max(x.vals)))==T )
y.inds <- which( ((df$y.pos >= min(y.vals)) & (df$y.pos <= max(y.vals)))==T )
# Find which entries has both x and y in current grid
inds <- which( x.inds %in% y.inds )
# If there's any such coordinates
if (length(inds) > 0){
# Append to list
a[[cnt]] <- data.frame("x.start"=min(x.vals), "x.stop"=max(x.vals),
"y.start"=min(y.vals), "y.stop"=max(y.vals),
"acc.heat"=sum(df$heat[inds],na.rm = T) )
# Increment counter variable
cnt <- cnt + 1
}
}
}
# Construct data.frame from list
heat.dens.df <- do.call(rbind,a)
# Plot again
ggplot(data=heat.dens.df,aes(x=x.start,y=y.start)) +
annotation_custom(g, xmin=-Inf, xmax=Inf, ymin=-Inf, ymax=Inf) +
geom_rect(data=heat.dens.df, aes(xmin=x.start, xmax=x.stop, ymin=y.start, ymax=y.stop, fill=acc.heat), alpha=0.5) +
scale_fill_gradientn(colours = rev( rainbow(3) )) +
scale_x_continuous(expand=c(0,0)) +
scale_y_continuous(expand=c(0,0))
Coordinate conversion from your data to my format can be done like:
sensor.data <- read.csv("~/Sample_Dataset.csv - Sample_Dataset.csv.csv")
# Create position -> coord conversion
pos.names <- names(sensor.data)[ grep("*Pos",names(sensor.data)) ] # Get column names with "Pos" in them
mock.coords <<- list()
lapply(pos.names, function(name){
# Create mocup coords between 0-1
mock.coords[[name]] <<- data.frame("x"=runif(1),"y"=runif(1))
})
# Change format of your data matrix
df.l <- list()
cnt <- 1
for (i in 1:nrow(sensor.data)){
for (j in 1:length(pos.names)){
name <- pos.names[j]
curr.coords <- mock.coords[[name]]
df.l[[cnt]] <- data.frame("x.pos"=curr.coords$x,
"y.pos"=curr.coords$x,
"heat" =sensor.data[i,j])
cnt <- cnt + 1
}
}
# Create matrix
df <- do.call(rbind, df.l)