How do I custom the cluster options so that the markers aren't clustered by the default Leaflet markerOptions(count of markers), but by a function (mean, maximum or whatelse) that I choose?
For Java i could find tons of examples, but for R I couldn't find anything.
Only thing I could find is something that has to do with
"iconCreateFunction" and "JS()", but I don't know if it's right and how it works..
leaflet(data) %>%
addTiles() %>%
addMarkers(lng=data$lon, lat=data$lat, clusterOptions = list(iconCreateFunction = JS(...
Can somebody help me? Thanks in advance
Replying to old question however some users still may find this useful.
You need to pass custom iconCreateFunction javascript formula to markerClusterOptions()
The main challenge is how you pass data to the markers so that you can apply a formula to data which are in the cluster of markers. I have tried to read the javascript code which is on the example website, but since I don't know js I could only find a workaround.
Example website: http://leaflet.github.io/Leaflet.markercluster/example/marker-clustering-custom.html
The user is adding data into marker[i].number in populate() function.
If anyone knows how this work please add your solution which I assume will be better than what I currently use.
My workaround is to store data into addMarkers(... , title=myData, ...) or addCircleMarkers(... , weight=myData , ...)
library(leaflet)
# sample data to pass to markers
myData <- sample(x=1:1000, size=1000, replace=TRUE)
# add some NaN which may occur in real data
myData[sample(x=1:1000, size=100, replace=FALSE)] <- NaN
circle.colors <- sample(x=c("red","green","gold"),size=1000,replace=TRUE)
avg.formula =
"function (cluster) {
var markers = cluster.getAllChildMarkers();
var sum = 0;
var count = 0;
var avg = 0;
var mFormat = ' marker-cluster-';
for (var i = 0; i < markers.length; i++) {
if(markers[i].options.weight != undefined){
sum += markers[i].options.weight;
count += 1;
}
}
avg = Math.round(sum/count);
if(avg<333) {mFormat+='small'} else if (avg>667){mFormat+='large'}else{mFormat+='medium'};
return L.divIcon({ html: '<div><span>' + avg + '</span></div>', className: 'marker-cluster'+mFormat, iconSize: L.point(40, 40) });
}"
# in the above we loop through every marker in cluster access the options.weight
# which is our data, if data is not undefined (not NA or NaN) then we sum data
# and count occurrence
# at the end of code we check if average is more/less to assign default
# marker icons marker-cluster-small marker-cluster-medium marker-cluster-large
# for green yellow red respectively
# stroke = FALSE is a must if you store data in weights !!!
leaflet(quakes) %>% addTiles() %>%
addCircleMarkers(lng=~long,lat=~lat,radius=10,stroke=FALSE,fillOpacity=0.9,
fillColor = circle.colors,weight=myData,
popup=as.character(myData),
clusterOptions = markerClusterOptions(iconCreateFunction=JS(avg.formula)))
for any other custom formula you need to adjust
for (var i = 0; i < markers.length; i++) {
if(markers[i].options.weight != undefined){
sum += markers[i].options.weight;
count += 1;
}
}
Kind regards,
Peter
Related
I have created a grid and I want to plot a time series for each of the squares of this evenly distributed grid.
But I keep getting the same error:
Line 20: ImageCollection.fromImages, argument 'images': Invalid type.
Expected type: List<Image<unknown bands>>.
Actual type: List<ImageCollection>.
Actual value: [<ImageCollection>, <ImageCollection>, <ImageCollection>, <ImageCollection>, <ImageCollection>, <ImageCollection>]
If anyone is kind to provide some help, Id really appreciate it.
This is what I got so far:
var grid = ee.FeatureCollection("projects/ee-moreirarmt/assets/grid")
Map.centerObject(grid)
var chirps_col = ee.ImageCollection("UCSB-CHG/CHIRPS/PENTAD")
.select("precipitation")
.filterDate("2020-01-01", "2021-01-01")
var seq = ee.List.sequence(1, ee.Number(grid.size()))
var vizparam = ({bands:"precipitation",min: 13.39358901977539, max: 27.54470443725586,
palette: ['001137', '0aab1e', 'e7eb05', 'ff4a2d', 'e90000']})
var split_by_each_grid = seq.map(function(x){
var fil = grid.filterMetadata('id', 'equals', x)
var split_chirps_col = chirps_col.filterBounds(fil)
return split_chirps_col.set('id', x)})
var splitted_chirps_col = ee.ImageCollection.fromImages(split_by_each_grid)
for(var a = 1; a < splitted_chirps_col.size().getInfo() + 1; a++){
Map.addLayer(splitted_chirps_col.median().filter(ee.Filter.eq('id',a)), vizparam, "Chirps_per_grid"+a)
}
for(var a = 1; a < final_col.size().getInfo() + 1; a++){
var chart = Chart.image.seriesByRegion(splitted_chirps_col.filter(ee.Filter.eq('id',a)), grid, ee.Reducer.mean(), "precipitation", 5500)
print(chart)
}
Here's the code:
https://code.earthengine.google.com/fbdf0b0e9e1f395eaa8435b805bdc809
Thanks in advance and stay safe.
RStudio provides a nice function View (with uppercase V) to take a look into the data, but with R it's still nasty to get orientation in a large data set. The most common options are...
names(df)
str(df)
If you're coming from SPSS, R seems like a downgrade in this respect. I wondered whether there is a more user-friendly option? I did not find a ready-one, so I'd like to share my solution with you.
Using RStudio's built-in function View, it's white simple to have a variable listing for a data.frame similar to the one in SPSS. This function creates a new data.frame with the variable information and displays in the RStudio GUI via View.
# Better variables view
Varlist = function(sia) {
# Init varlist output
varlist = data.frame(row.names = names(sia))
varlist[["comment"]] = NA
varlist[["type"]] = NA
varlist[["values"]] = NA
varlist[["NAs"]] = NA
# Fill with meta information
for (var in names(sia)) {
if (!is.null(comment(sia[[var]]))) {
varlist[[var, "comment"]] = comment(sia[[var]])
}
varlist[[var, "NAs"]] = sum(is.na(sia[[var]]))
if (is.factor(sia[[var]])) {
varlist[[var, "type"]] = "factor"
varlist[[var, "values"]] = paste(levels(sia[[var]]), collapse=", ")
} else if (is.character(sia[[var]])) {
varlist[[var, "type"]] = "character"
} else if (is.logical(sia[[var]])) {
varlist[[var, "type"]] = "logical"
n = sum(!is.na(sia[[var]]))
if (n > 0) {
varlist[[var, "values"]] = paste(round(sum(sia[[var]], na.rm=T) / n * 100), "% TRUE", sep="")
}
} else if (is.numeric(sia[[var]])) {
varlist[[var, "type"]] = typeof(sia[[var]])
n = sum(!is.na(sia[[var]]))
if (n > 0) {
varlist[[var, "values"]] = paste(min(sia[[var]], na.rm=T), "...", max(sia[[var]], na.rm=T))
}
} else {
varlist[[var, "type"]] = typeof(sia[[var]])
}
}
View(varlist)
}
My recommendation is to store that as a file (e.g., Varlist.R) and whever you need it, just type:
source("Varlist.R")
Varlist(df)
Again please take note of the uppercase V using as function name.
Limitation: When working with data.frame, the listing will not be updated unless Varlist(df) is run again.
Note: R has a built-in option to view data with print. If working with pure R, just replace the View(varlist) by print(varlist). Yet, depending on screen size, Hmisc::describe() could be a better option for the console.
Can someone recommend an efficient way to sift through each row in a dataframe and manually classify it? For example I might be wanting to separate spam from e-mail, or shortlist job adverts, job applicants, or dating agency profiles (I understand Tinder does this by getting you to swipe left or right).
My dataset is small enough to classify manually. I suppose if it was larger I might only want to manually classify a portion of it in order to train a machine-learning algorithm such as Naive Bayes to finish the task for me.
I'll show you what I've got at the moment, but this isn't a particularly original task, so there must be a less crude way to do this that someone has already thought of! (As a newcomer, I'm impressed by the power of R, but also nonplussed when little tasks like clearing the screen or capturing a keystroke turn out to be non-trivial)
# Let us suppose I am using this built-in dataset to draw up a
# shortlist of where I might wish to go on holiday
df <- data.frame(state.x77);
# pp - define a task-specific pretty print function
pp <- function(row) {
print(row); # Example dataset is simple enough to just print the entire row
}
# cls - clear the screen (this hack works on Windows but I've commented it for now)
cls <- function() {
#system("powershell -ExecutionPolicy Bypass -command (New-Object -ComObject Wscript.Shell).SendKeys([string][char]12)");
}
# It would halve the number of keystrokes needed if I knew a way to read
# a single character
readcharacter <- readline;
sift <- function(df, pp)
{
classification = rep('', nrow(df));
for (nRow in 1:nrow(df))
{
cls();
pp(df[nRow,]);
cat("\nEnter 'a' to discard, 'd' to keep, 'q' to quit\n");
char <- '';
while (char != 'a' && char != 'd' && char != 'q') {
char <- readcharacter();
}
if (char == 'q')
break;
classification[nRow] = char;
}
return(cbind(df,classification=classification));
}
result = sift(df, pp);
cls();
cat("Shortlist:\n");
print(row.names(result[result$classification=='d',]));
So how does the StackOverflow community feel about me using this Shiny app to solve my problem? I wouldn't expect to see Shiny used in this early part of data analysis - normally it only comes into play once we have some results we'd like to explore or present dynamically.
Learning Shiny was fun and useful, but I'd much prefer it if a less complicated answer could be found.
library(shiny);
#
# shortlist - function that allows us to shortlist through the rows in a data frame efficiently
#
shortlist <- function(df, sTitle, sRowName) {
createUI <- function() {
listHeading <- list(
textOutput(outputId = "Progress"),
tags$br(),
fluidRow(
column(width=1, sRowName),
column(width=9, textOutput(outputId = "RowName"))));
listFields <- lapply(names(df), function(sFieldname) {
return(fluidRow(
column(width=1, sFieldname),
column(width=9, textOutput(outputId = sFieldname))));
});
listInputs <- list(
tags$br(),
tags$table(
tags$tr(
tags$td(" "),
tags$td(actionButton(inputId="Up", label="W", disabled=TRUE, width="100%"))),
tags$tr(
tags$td(width="100px", actionButton(inputId="Discard", label="Discard, A", width="100%")),
tags$td(width="100px", actionButton(inputId="Down", label="S", disabled=TRUE, width="100%")),
tags$td(width="100px", actionButton(inputId="Keep", label="Keep, D", width="100%")))),
tags$script("
// JavaScript implemented keyboard shortcuts, including lots of conditions to
// ensure we're finished processing one keystroke before we start the next.
var bReady = false;
$(document).on('shiny:recalculating', function(event) {
bReady = false;
});
$(document).on('shiny:recalculated', function(event) {
setTimeout(function() {bReady = true;}, 500);
});
$(document).on('keypress', function(event) {
if (bReady) {
switch(event.key.toLowerCase()) {
case 'a':
document.getElementById('Discard').click();
bReady = false;
break;
case 'd':
document.getElementById('Keep').click();
bReady = false;
break;
}
}
});
// End of JavaScript
"));
listPanel <- list(
title = sTitle,
tags$br(),
conditionalPanel(
condition = paste("input.Keep + input.Discard <", nrow(df)),
append(append(listHeading, listFields), listInputs)));
listShortlist <- list(
tags$hr(),
tags$h4("Shortlist:"),
dataTableOutput(outputId="Shortlist"));
ui <- do.call(fluidPage, append(listPanel, listShortlist));
return(ui);
}
app <- shinyApp(ui = createUI(), server = function(input, output) {
classification <- rep('', nrow(df));
getRow <- reactive({
return (input$Keep + input$Discard + 1);
});
classifyRow <- function(nRow, char) {
if (nRow <= nrow(df)) {
classification[nRow] <<- char;
}
# In interactive mode, automatically stop the app when we're finished
if ( interactive() && nRow >= nrow(df) ) {
stopApp(classification);
}
}
observeEvent(input$Discard, {classifyRow(getRow() - 1, 'a')});
observeEvent(input$Keep, {classifyRow(getRow() - 1, 'd')});
output$Progress = renderText({paste("Showing record", getRow(), "of", nrow(df))});
output$RowName = renderText({row.names(df)[getRow()]});
lapply(names(df), function(sFieldname) {
output[[sFieldname]] <- renderText({df[getRow(), sFieldname]});
});
output$Shortlist <- renderDataTable(options = list(paging = FALSE, searching = FALSE), {
# Mention the 'keep' input to ensure this code is called when the 'keep' button
# is pressed. That way the shortlist gets updated when an item to be added to it.
dummy <- input$Keep;
# Construct the shortlist
shortlist <- data.frame(row.names(df[classification == 'd',]));
colnames(shortlist) <- sRowName;
return(shortlist);
});
});
if (interactive()) {
classification <- runApp(app);
return(cbind(df, classification = classification));
} else {
return(app);
}
}
#
# And now some example code.
# Shortlist the built in state.x77 data set (let us suppose I am drawing up
# a shortlist of where I might wish to go on holiday)
#
df <- data.frame(state.x77);
result <- shortlist(df = df, "Choose states", "State");
if (interactive()) {
cat("Shortlist:\n");
print(row.names(result[result$classification == 'd',]));
} else {
return (result);
}
Trying to pull a list of ratings from a collection of Reviews and then average them to come up with an aggregated average rating for a Plate. When I look at the data output from the ratings variable I get nothing but "undefined undefined undefined".
averageRating: function() {
var reviews = Reviews.findOne({plateId: this._id});
var ratings = _.pluck(reviews, 'rating');
var sum = ratings.reduce(function(pv, cv){return pv + cv;}, 0);
var avg = sum / ratings.length;
//Testing output
var test = "";
var x;
for (x in reviews) {
text += reviews[x] + ',';
}
return test;
}
Sorry if this is a super newbie question, but I've been at this for hours and cannot figure it out.
I figured out the issue. As listed above var reviews gets set to a cursor which apparently .pluck does not work on. By first converting the cursor to an array of objects I was then able to use .pluck. So updated code looks like this:
averageRating: function() {
var reviewsCursor = Reviews.find({plateId: this._id});
//Converts cursor to an array of objects
var reviews = reviewsCursor.fetch();
var ratings = _.pluck(reviews, 'rating');
var sum = ratings.reduce(function(pv, cv){return pv + cv;}, 0);
var avg = (sum / ratings.length).toPrecision(2);
return avg;
}
How can I change the axis titles of a plot generated with rCharts and the dimple.js library? For example:
library(rCharts)
data(mtcars)
mtcars.df <- data.frame( car = rownames(mtcars), mtcars )
d1 <- dPlot(x ="disp", y="mpg", groups=c("car", "cyl"), type ="point", data=mtcars.df)
d1$xAxis( type = "addMeasureAxis")
d1
The desired effect is to replace the variable name "disp" with a more complete piece of text as the axis title. I've tried adding arguments to the d1$xAxis() line like title="Displacement" and label="Displacement: but without success.
Sorry I just saw this. Thanks John for answering.
With rCharts, we can take advantage of the afterScript template to add this. If there is only one chart in the DOM, we can use John's example unmodified.
d1$setTemplate(
afterScript =
'
d3.selectAll(".axis.title")
.text(function () {
var t = d3.select(this).text();
if (t === "disp") {
return "Displacement";
} else if (t === "mpg") {
return "Miles Per Gallon";
} else {
return t;
}
});
'
)
Please let me know if this you would like an example with multiple charts in the DOM or this does not work for you. Thanks.
Dimple doesn't currently expose the titles, however it's coming in the next release. Once it does I'm sure the great guys behind the dimple implementation in rcharts will add them into the library. I'm not quite sure how this works with an R implementation but if you can run some Javascript once the chart is rendered you can modify the titles using some raw d3:
d3.selectAll(".axis.title")
.text(function () {
var t = d3.select(this).text();
return (t === "disp" ? "Displacement" : t);
});
If you want to extend this to replace a couple of titles you can do it with:
d3.selectAll(".axis.title")
.text(function () {
var t = d3.select(this).text();
if (t === "disp") {
return "Displacement";
} else if (t === "mpg") {
return "Miles Per Gallon";
} else {
return t;
}
});
I hope this helps.
Here is another way:
# devtools::install_github("rCharts", "ramnathv", ref = "dev")
library(rCharts)
data(mtcars)
mtcars.df <- data.frame( car = rownames(mtcars), mtcars )
d1 <- dPlot(x ="disp", y="mpg", groups=c("car", "cyl"), type ="point", data=mtcars.df)
d1$xAxis( type = "addMeasureAxis")
d1
d1$setTemplate(afterScript = "
<script>
myChart.draw()
myChart.axes[0].titleShape.text('Displacement')
myChart.axes[1].titleShape.text('Miles Per Gallon')
myChart.svg.append('text')
.attr('x', 40)
.attr('y', 20)
.text('Plot of Miles Per Gallon / Displacement')
.style('text-anchor','beginning')
.style('font-size', '100%')
.style('font-family','sans-serif')
</script>
")
d1
Screenshot:
Hat tip to Ramnath: R: interactive plots (tooltips): rCharts dimple plot: formatting axis