We Keep Coding

Leaflet.LabelTextCollision plugin doesn't work in R with leaflet

Leaflet.LabelTextCollision plugin is a usefull feature for spatial visualisation. It hides labels on the map, which overlap with each other.
I try to use Leaflet.LabelTextCollision in R with leaflet package, but it doesn't work. What did i miss? I'm not familiar with JS, but, as far as i understand, i should implement JS function in the R code (see onRender in the example).
I asked the same question on Github a year ago, but still I haven't recieved an answer (https://gist.github.com/jcheng5/c084a59717f18e947a17955007dc5f92?permalink_comment_id=3814855#gistcomment-3814855).
Link to the Leaflet.LabelTextCollision plugin:
https://github.com/yakitoritabetai/Leaflet.LabelTextCollision
Here is an example of my code.
library(tidyverse)
library(leaflet)
library(htmltools)
library(htmlwidgets)
setwd("D:/Data/page_ex")
label <- data.frame(
lat = c(61.09049, 56.89039, 57.52678, 60.74516, 56.92379, 64.54302, 56.25897, 56.49648, 56.27996, 56.74812, 59.93873, 56.77972, 56.85867, 60.08370, 56.25897),
lon = c(43.17148, 32.65250, 38.31669, 42.04732, 32.74461, 40.53712, 32.08586, 31.64108, 31.66774, 33.51162, 30.31623, 31.25263, 35.92083, 30.27957, 32.08586),
name_label = c("label_1", "label_2", "label_1000", "label_10000", "label_70000", "label_8", "label_999999", "label_777", "label_888888", "label_888", "label_999", "label_7", "label_9", "label_777777777", "label_999999999")
)
col_Plugin <- htmlDependency(
"Leaflet.LabelTextCollision", "1.4.0",
src = "./Leaflet.LabelTextCollision-master/dist",
script = "L.LabelTextCollision.js"
)
registerPlugin <- function(map, plugin) {
map$dependencies <- c(map$dependencies, list(plugin))
map
}
leaflet() %>%
setView(35, 60, zoom = 4) %>%
addProviderTiles(provider = "OpenStreetMap") %>%
registerPlugin(col_Plugin) %>%
addLabelOnlyMarkers(lng = label$lon,
lat = label$lat,
label = lapply(label$name_label, HTML),
labelOptions = labelOptions(noHide = T,
textOnly = F,
direction = "top")
) %>%
onRender("function(el, x) {
L.LabelTextCollision(collisionFlg : true).addTo(this);}")

How to freeze left column of matrix viewed in R shiny modal dialog?

The below reproducible code renders a user input matrix grid inside a modal dialog box (click on the single action button at the top when invoking the App), with the user input matrix: (a) automatically expanding to the right as the user inputs data into the columns, (b) automatically generating sequentially numbered column headers, and (c) rendered inside a scrollable well panel so that it expands without "scrunching" as it grows.
However, I would like to "freeze" the left-most column of the matrix input grid (the row headers), so the user doesn't lose the meanings of individual rows as the grid grows. The images at the bottom better illustrate. How can this be done?
I assume this requires some gyrations with shinyjs, an area I am very weak in. This is a follow-up evolution of earlier post In R shiny, how to incorporate scrolling into modal dialog box?
Reproducible code:
library(shiny)
library(shinyMatrix)
library(shinyjs)
library(shinyWidgets)
library(magrittr)
library(DT)
mat1DefaultRownames <- c('Item A','Item B','Item C','Item D')
mat1Default <- data.frame('Series 1'=c(1,24,0,100), row.names = mat1DefaultRownames) %>% as.matrix()
mat1Input <- function(inputId, mat1Default) {
matrixInput(
inputId = inputId,
label = "Input terms:",
value = mat1Default,
rows = list(extend = FALSE, names = TRUE),
cols = list(extend = TRUE, names = TRUE, editableNames = FALSE, delete = TRUE),
class = "numeric"
)
}
ui <-
fluidPage(
shinyjs::useShinyjs(),
div(style = "margin-top: 10px"),
actionButton('modInputs','Input terms', style = 'width:25%'),
DTOutput("table1")
)
server <- function(input,output,session)({
rv1 <- reactiveValues(
mat1 = mat1Input("mat1",mat1Default),
input = mat1Default,
colHeader = colnames(input)
)
mat1Inputs <- reactive({
if (isTruthy(input$modInputs)) {
req(input$mat1)
df <- input$mat1
rv1$mat1 <- mat1Input("mat1", df)
colnames(df) <- paste("Series",rep(1:ncol(df),each=1,length.out=ncol(df)))
rownames(df) <- mat1DefaultRownames
rv1$input <- df
updateMatrixInput(session, inputId = "mat1", value = rv1$input)
} else {
df <- mat1Default
colnames(df) <- paste("Series", 1:ncol(df))
}
df[3:4, ] <- sprintf('%.2f%%', df[3:4, ])
df
})
output$table1 <-
renderDT(server = TRUE, {
datatable(
data = mat1Inputs(),
options = list(
scrollX = T,
dom = 'ft',
autoWidth = FALSE,
info = FALSE,
searching = FALSE,
columnDefs =
list(
list(className = 'dt-left', targets = 0),
list(className = 'dt-right', targets = seq_len(ncol(mat1Inputs())))
)
),
class = "display nowrap"
)
})
observeEvent(input$modInputs, {
showModal(
modalDialog(
wellPanel(div(style = "overflow-x: auto;", rv1$mat1)),
footer = tagList(actionButton("resetInputs", "Reset"),modalButton("Close"))
)
)
})
observeEvent(c(input$modInputs, input$mat1), {
runjs(
paste0(
'$("#mat1").css("width","calc(100% + ', (dim(input$mat1)[2]-1 + dim(input$mat1)[2]%%2)*115, 'px")'
) # close paste0
) # close runjs
})
observeEvent(input$resetInputs, {updateMatrixInput(session,'mat1', mat1Default)})
})
shinyApp(ui, server)

R shiny DT hover shows detailed table

I am trying to work on an R shiny app where I want to show a consolidated table on top and when the user hovers on any line item it would show the detailed section of that table.So here's the code for the first table
library(ggplot2)
ui <- fluidPage(
titlePanel("Basic DataTable"),
# Create a new row for the table.
DT::dataTableOutput("table")
)
server <- function(input, output) {
data <- mpg
data <-data %>% group_by(manufacturer,year) %>%
summarise(cty = round(mean(cty),2),hwy = round(2,mean(hwy)))
# Filter data based on selections
output$table <- DT::renderDataTable(DT::datatable({
data
}))
}
shinyApp(ui,server)
Now when the user hovers on Audi for example it should show a detailed version just forAudi something like this in a table below.Can this be done in shiny with DT on hover or click.

Here is a way. If you prefer to display the child table on click rather than on hover, replace "table.on('mouseover', 'td', function(){" with "table.on('click', 'td', function(){".
library(shiny)
library(DT)
data(mpg, package = "ggplot2")
callback <- c(
"table.on('mouseover', 'td', function(){",
" var index = table.cell(this).index();",
" Shiny.setInputValue('cell', index, {priority: 'event'});",
"});"
)
ui <- fluidPage(
br(),
DTOutput("tbl")
)
server <- function(input, output, session){
dat <- mpg
output[["tbl"]] <- renderDT({
datatable(
dat,
callback = JS(callback)
)
})
filteredData <- eventReactive(input[["cell"]], {
i <- input[["cell"]]$row + 1
j <- input[["cell"]]$column
if(j > 0){
dat[dat[[j]] == dat[i,j], , drop = FALSE]
}else{
NULL
}
})
output[["tblfiltered"]] <- renderDT({
datatable(
filteredData(),
fillContainer = TRUE,
options = list(
pageLength = 5
)
)
})
observeEvent(filteredData(), {
showModal(
modalDialog(
DTOutput("tblfiltered"),
size = "l",
easyClose = TRUE
)
)
})
}
shinyApp(ui, server)

R Shiny Dynamic text in header (reactive renderUI)

I am trying to put dynamic text in shiny's header, and have managed to put text in it, but cannot get it to update after it has received new data from an reactive expression. To put text in the header, I have used a basic Java call, tags$script.
My concern is that renderUI only renders the 1st time, and does not force render whenever the reactive value (val) is updated, which is exactly what I require.
Apologies for the weird example below, I have a HUGE dashboard which has several chained dependencies, and I have tried to replicate the types of dependencies in the reproducible example below.
library(shiny)
library(shinydashboard)
ui <- fluidPage(
dashboardPage(skin = 'black',
dashboardHeader(title = "test"),
dashboardSidebar(
sidebarMenu(id = 'MenuTabs',
menuItem("dummy", tabName = "rawanalysis", selected = TRUE, icon = icon("dashboard"))
)
),
dashboardBody(
uiOutput(outputId = 'Header'),
fluidRow(
box(
actionButton("change", "Change")
)
))))
server <- function(input, output) {
Go_rv <- reactiveValues(val = 0)
observeEvent(input$change, {
sam <- rnorm(1)
if(sam > 0){
Go_rv$val <- TRUE
} else {
Go_rv$val <- FALSE
}
})
val <- reactive({
print(Go_rv$val)
if(Go_rv$val){
out <- 0
} else {
out <- -5
}
return(out)
})
output$Header <- renderUI({
removeUI(
selector = "div:has(> #Header)"
)
header_text <- paste0('$(document).ready(function() {
$("header").find("nav").append(\'<div class="myClass">', val(), '</div>\');})')
tags$script(HTML(header_text),
id = 'Header'
)
})
}
shinyApp(ui = ui, server = server)

Basically, a reactive text output with observeEvent should do this job!
library(shiny)
library(shinydashboard)
ui <- fluidPage(
dashboardPage(skin = 'black',
dashboardHeader(title = textOutput('test')),
dashboardSidebar(
sidebarMenu(id = 'MenuTabs',
menuItem("dummy", tabName = "rawanalysis", selected = TRUE, icon = icon("dashboard"))
)
),
dashboardBody(
#uiOutput(outputId = 'Header'),
fluidRow(
box(
actionButton("change", "Change")
)
))))
server <- function(input, output,session) {
title_change <- reactive({
input$change
as.character(Sys.time())
})
observeEvent(input$change, { output$test <- renderText({ title_change()
})
})
}
shinyApp(ui = ui, server = server)

Collecting data with RSelenium- looping dropdown menus with buttons

I am having difficulties with collecting data on changes in Spanish municipalities over time. I have been trying to use this answer as a guide, but I think I am running into problems because in order to move from one dropdown menu to another, a button needs to be clicked. I can't figure out where to work the button into the code.
What I have so far:
#access web page
remDr <- remoteDriver(browserName="firefox", port=4444)
remDr$open(silent=T)
remDr$setImplicitWaitTimeout(3000)
remDr$navigate("http://www.ine.es/intercensal/")
I can access the tables I want individually by entering values into each of three elements (Autonomous community, Province, and Municipality) and clicking buttons, for example:
remDr$executeScript("document.getElementById('cmbCCAA').value = 1;")
ConsultProv <- remDr$findElement(using = 'name', value = 'btnBuscarProv')
ConsultProv$clickElement()
remDr$executeScript("document.getElementById('cmbProv').value = 4;")
ConsultMuni <- remDr$findElement(using = 'name', value = 'btnBuscarMuni')
ConsultMuni$clickElement()
remDr$executeScript("document.getElementById('cmbMuni').value = 5861;")
SubmitMuni <- remDr$findElement(using = 'name', value = 'btnBuscarGeo')
SubmitMuni$clickElement()
And while the code may be inelegant (apologies, but I just began learning R), I can pull individual table data with:
readname <- remDr$findElement(using = 'css selector', value = '.TITULOH3')
namedata <- readname$getElementText()
cleanname1 <- gsub("Province: ", "", namedata)
separatename1 <- str_split(cleanname1, "Municipality: ")
separatename2 <- unlist(separatename1, recursive = TRUE, use.names = TRUE)
trimmed <- trimws(separatename2)
names(trimmed) <- data.frame("Province", "Municipality", stringsAsFactors = FALSE)
finalname <- t(trimmed)
table <- htmlParse(remDr$getPageSource()[[1]])
readdfdata <- readHTMLTable(table, skip.rows = c(1, 2, 4, 5), stringsAsFactors = FALSE)
tabledfdata <- as.data.frame(readdfdata[2])
names(tabledfdata) <- c("skip", "dfpop1842", "dfpop1857", "dfpop1860", "dfpop1877", "dfpop1887", "dfpop1897",
"dfpop1900", "dfpop1910", "dfpop1920", "dfpop1930", "dfpop1940", "dfpop1950", "dfpop1960",
"dfpop1970", "dfpop1981", "dfpop1991", "dfpop2001", "dfpop2011")
cleandftable <- subset(tabledfdata, select = -c(skip))
finaldfpop <- cleandftable
readdjdata <- readHTMLTable(table, skip.rows = c(1, 2, 3, 5), stringsAsFactors = FALSE)
tabledjdata <- as.data.frame(readdjdata[2])
names(tabledjdata) <- c("skip", "djpop1842", "djpop1857", "djpop1860", "djpop1877", "djpop1887", "djpop1897",
"djpop1900", "djpop1910", "djpop1920", "djpop1930", "djpop1940", "djpop1950", "djpop1960",
"djpop1970", "djpop1981", "djpop1991", "djpop2001", "djpop2011")
cleandjtable <- subset(tabledjdata, select = -c(skip))
finaldjpop <- cleandjtable
readhhdata <- readHTMLTable(table, skip.rows = c(1, 2, 3, 4), stringsAsFactors = FALSE)
tablehhdata <- as.data.frame(readhhdata[2])
names(tablehhdata) <- c("skip", "hh1842", "hh1857", "hh1860", "hh1877", "hh1887", "hh1897",
"hh1900", "hh1910", "hh1920", "hh1930", "hh1940", "hh1950", "hh1960",
"hh1970", "hh1981", "hh1991", "hh2001", "hh2011")
cleanhhtable <- subset(tablehhdata, select = -c(skip))
finalhhpop <- cleanhhtable
readchange <- remDr$findElement(using = 'css selector', value = '.alteraciones')
changedata <- readchange$getElementText()
separatechange1 <- str_split(changedata, "\\n ")
separatechange2 <- unlist(separatechange1, recursive = TRUE, use.names = TRUE)
finalchange <- t(separatechange2)
complete <- data.frame(finalname, finaldfpop, finaldjpop, finalhhpop, finalchange, stringsAsFactors = FALSE)
But how do I loop this process in order to collect data for all municipalities? I tried using the changeFun from the previous answer while also incorporating the buttons, but the following code gets stuck:
#Pre-existing changeFun
changeFun <- function(value, elementName, targetName){
changeElem <- remDr$findElement(using = "name", elementName)
script <- paste0("arguments[0].value = '", value, "'; arguments[0].onchange();")
remDr$executeScript(script, list(changeElem))
targetCodes <- c()
while(length(targetCodes) == 0){
targetElem <- remDr$findElement(using = "name", targetName)
target <- xmlParse(targetElem$getElementAttribute("outerHTML")[[1]])
targetCodes <- sapply(querySelectorAll(target, "option"), xmlGetAttr, "value")[-1]
target <- sapply(querySelectorAll(target, "option"), xmlValue)[-1]
if(length(targetCodes) == 0){
Sys.sleep(0.5)
}else{
out <- list(target, targetCodes)
}
}
return(out)
}
#This part works fine in getting autonoma names and codes
autonomas <- remDr$findElement(using = "name", "cmbCCAA")
autonomasdata <- autonomas$getElementAttribute("outerHTML")[[1]]
autocodes <- sapply(querySelectorAll(xmlParse(autonomasdata), "option"), xmlGetAttr, "value")[-1]
autos <- sapply(querySelectorAll(xmlParse(autonomasdata), "option"), xmlValue)[-1]
#But this part for getting Province and Municipality names and codes does not run
autonoma <- list()
for(x in seq_along(autocodes)){
ConsultProv <- remDr$findElement(using = 'name', value = 'btnBuscarProv')
ConsultProv$clickElement()
province <- changeFun(autocodes[[x]], "cmbCCAA", "cmbProv")
municipality <- lapply(province[[2]], function(y){
ConsultMuni <- remDr$findElement(using = 'name', value = 'btnBuscarMuni')
ConsultMuni$clickElement()
municipality <- changeFun(y, "cmbProv", "cmbMuni")
municipality}
)
list(municipality)}
)
autonoma[[x]] <- list(province, municipality)
}
Any advice on how to make the loop work would be greatly appreciated. I think the problem I am having is in incorporating the button clicking, but I can't seem to figure out how to do it. Thanks!
Edits
I have done some messing around with this, and I still think the issue is with incorporating the button clicking. I have created a Frankenstein's-monster of code below that does... something. Basically, I think I need to incorporate JavaScript in an executeScript command somewhere, either in the ChangeFun or in the larger code. Not sure if me narrowing it down in this way helps at all, but I thought I would update everyone on my (lack of) progress.
sel_auto <- remDr$findElement(using = 'name', value = 'cmbCCAA')
raw_auto <- sel_auto$getElementAttribute("outerHTML")[[1]]
num_auto <- sapply(querySelectorAll(xmlParse(raw_auto), "option"), xmlGetAttr, "value")[-1]
nam_auto <- sapply(querySelectorAll(xmlParse(raw_auto), "option"), xmlValue)[-1]
for (i in seq_along(num_auto)){
remDr$executeScript("document.getElementById('cmbCCAA').value = 1;")
clk_auto <- remDr$findElement(using = 'name', value = 'btnBuscarProv')
clk_auto$clickElement()
sel_prov <- remDr$findElement(using = 'name', value = 'cmbProv')
raw_prov <- sel_prov$getElementAttribute("outerHTML")[[1]]
num_prov <- sapply(querySelectorAll(xmlParse(raw_prov), "option"), xmlGetAttr, "value")[-1]
nam_prov <- sapply(querySelectorAll(xmlParse(raw_prov), "option"), xmlValue)[-1]
for (j in seq_along(num_prov)){
sel_prov$clickElement()
clk_prov <- remDr$findElement(using = 'name', value = 'btnBuscarMuni')
clk_prov$clickElement()
sel_muni <- remDr$findElement(using = 'name', value = 'cmbMuni')
raw_muni <- sel_muni$getElementAttribute("outerHTML")[[1]]
num_muni <- sapply(querySelectorAll(xmlParse(raw_muni), "option"), xmlGetAttr, "value")[-1]
nam_muni <- sapply(querySelectorAll(xmlParse(raw_muni), "option"), xmlValue)[-1]
}
}