Requires leaflegend >= 1.0.0

Base Data and Map

library(leaflet)
library(leaflegend)
mapData <- data.frame(x = c(2, 1, 5, 4,3) , y = c('A', 'B', 'C', 'B', 'A'), 
                      lng = -(118:122), lat = rep(42, 5))
map <- leaflet::leaflet(data = mapData, 
                        options = leafletOptions(zoomControl = FALSE))

Color Scales

Create Legend for a Continuous Scale

numPal <- colorNumeric('inferno', mapData$x)
lgd <- 
  map |> addLegendNumeric(pal = numPal, values = ~x, decreasing = TRUE) |> 
  addLegendNumeric(pal = numPal, values = ~x, orientation = 'horizontal',
                   width = 120, height = 20, position = 'topright')
lgd

Create Legend for Quantiles

quantPal <- colorQuantile('Reds', mapData$x, n = 3)
lgd <- 
  map |> addLegendQuantile(pal = quantPal, values = ~x) |> 
    addLegendQuantile(pal = quantPal, values = ~x, numberFormat = NULL, 
                      position = 'topright')
lgd

Create Legend for Bins and Change Legend Symbol

binPal <- colorBin(c('grey', 'blue'), mapData$x, bins = 3, pretty = FALSE)
lgd <- 
  map |> addLegendBin(pal = binPal, shape = 'triangle')
lgd

Create Legend for Factors and Re-order

factorPal <- colorFactor('Dark2', domain = mapData$y)
reOrder <- c('C', 'A', 'B')
factorPalRev <- colorFactor('Dark2', domain = reOrder, ordered = TRUE)
lgd <- 
  map |> addLegendFactor(pal = factorPal, values = ~y) |> 
    addLegendFactor(pal = factorPalRev, 
                    values = ~factor(y, levels = reOrder), 
                    position = 'topright')
lgd

Symbols and Size Scales

Legend and Points with Size Encoding

lgd <- 
  map |> addLegendSize(values = ~x, color = 'black', shape  = 'plus', 
                       breaks = 3) |> 
    addSymbolsSize(lng = ~lng, lat = ~lat, values = ~x, shape = 'plus', 
                   color = 'black')
lgd

Legend and Points with Double Encoding

lgd <- 
  map |> addLegendSize(values = ~x, shape  = 'plus', breaks = 3, pal = numPal,
                       color = 'black') |> 
    addSymbolsSize(lng = ~lng, lat = ~lat, values = ~x, shape = 'plus', 
                   color = 'black', fillColor = ~numPal(x))
lgd

Legend and Points with Size and Color Encoding

lgd <- 
  map |> addLegendSize(values = ~x, shape  = 'plus', breaks = 3, pal = numPal,
                       color = 'black', fillColor = 'transparent') |> 
    addSymbolsSize(lng = ~lng, lat = ~lat, values = ~x, shape = 'plus', 
                   color = 'black', fillColor = ~factorPal(y)) |> 
    addLegendFactor(pal = factorPal, values = ~y, position = 'topright')
lgd

Legend and Points with Symbol Encoding

lgd <- 
  map |> addSymbols(lng = ~lng, lat = ~lat, values = ~y, color = 'black') |> 
    addLegendSymbol(values = ~y, color = 'black')
lgd

Legend and Points with Symbol Encoding (Non-Defaults)

lgd <- 
  map |> addSymbols(lng = ~lng, lat = ~lat, values = ~y, 
                    fillColor = ~factorPal(y), color = 'black',
                    shape = c('cross', 'diamond', 'star')) |> 
    addLegendSymbol(values = ~y, pal = factorPal, 
                    shape = c('cross', 'diamond', 'star'), color = 'black')
lgd

Legend for Line Size Encodings

lgd <- 
  map |> addLegendLine(values = ~x, color = 'black', 
                       orientation = 'horizontal', width = 50)
lgd

Images

Add Custom Images to a Legend

# use raster image
leafImg <- system.file('img/leaf-blue.png', package = 'leaflegend')
# use svg
circle <- makeSymbol('rect', fillColor = 'red', color = 'black', width = 20)
lgd <- 
  map |> 
    addLegendImage(images = list(leafImg, circle), labels = c('png', 'svg'),
                   height = 30, width = 20)
lgd

Generate Map Symbols

shapes <- c('rect', 'circle', 'triangle', 'plus', 'cross', 'star')
colors <- c('blue', 'red', 'yellow', 'green', 'orange', 'purple')
symbols <- Map(f = makeSymbol, shape = shapes, fillColor = colors, 
               color = 'black', opacity = 1, fillOpacity = .5, width = 20, 
               `stroke-width` = 2)
lgd <- 
  map |> addLegendImage(images = symbols, labels = shapes, 
                        orientation = 'horizontal')
lgd

Add Awesome Marker Legend and Specify Icon as Text

iconSet <- awesomeIconList(
  `Font Awesome` = makeAwesomeIcon(icon = "font-awesome", library = "fa",
                                   markerColor= 'red', iconColor = 'black'),
  Ionic = makeAwesomeIcon(icon='R', library = 'fa', 
                          text = fontawesome::fa("r-project"))
)
lgd <- 
  map |> addLegendAwesomeIcon(iconSet = iconSet)
lgd

Customization

Turn off Legend Background

lgd <- 
  map |> addLegendFactor(values = ~y, pal = factorPal, 
                         class = 'leaflet-control', 
                         labelStyle = 'color: black;')
lgd

Add Titles with Styling

lgd <- 
  map |> addLegendFactor(values = ~y, pal = factorPal, 
                         title = htmltools::tags$div('Red Title', 
                                                     style = 'color:red;'))
lgd

Change Label Styling

lgd <- 
  map |> addLegendFactor(values = ~y, pal = factorPal, 
                         labelStyle = 'color: blue; font-size: 10px;')
lgd

Symbol Styling

lgd <- 
  map |> addLegendFactor(values = ~y, pal = factorPal, shape = 'polygon',
                         fillOpacity = .5, width = 20, height = 20)
lgd

Make Symbol Icons

symbolSet <- makeSymbolIcons(shape = c('rect', 'circle', 'triangle'), 
                             width = 10, color = 'grey', opacity = 1)
lgd <- 
  map |> addMarkers(lng = ~lng, lat = ~lat, icon = ~symbolSet[as.factor(y)])
lgd

Make Symbols with Size Encodings

lgd <- 
  map |> addMarkers(lng = ~lng, lat = ~lat, 
                    icon = ~makeSymbolsSize(x, color = 'black', 
                                            fillColor = 'black',
                                            baseSize = 20, 
                                            fillOpacity = .5))
lgd

Legends with Overlay Controls

lgd <- 
  map |> addLegendFactor(values = ~y, pal = factorPal, group = 'Legend') |> 
    addLayersControl(overlayGroups = 'Legend', 
                     options = layersControlOptions(collapsed = FALSE))
lgd

[CRAN] [github]

, and can specify the icon color (it’s a font!) with any specification that is supported in HTML/CSS. While many of the icons can be self-explanatory, best practice is to always provide a legend for encodings whether it is a map or a plot. Creating an awesome marker legend is possible using only leaflet but requires the user to write some HTML and CSS to put into the addControl function. leaflegend provides a new function addLegendAwesomeIcon that automates this task and preserves all the same features of the markers that are drawn on a map.

Creating an Awesome Marker Legend

To create awesome icons for the map and the legend, use the same method as in the example documentation from leaflet and create an icon set. All of the options provided in makeAwesomeIcon will render in the legend. You only need to pass the icon set into the addLegendAwesomeIcon function with a named icon list that will be the labels for the icon markers. As with the other addLegend*() functions in leaflegend, the user has full control over the title, label style, etc. Grouping controls are now supported for all legends as of version 0.4.0.

library(leaflet)
library(leaflegend)
library(sf)
library(osmdata)

foodDrink <- opq(bbox= c(-122.367375,
                         47.643819,
                         -122.323258,
                         47.658698)) |>
  add_osm_feature(key = 'amenity', 
                  value = c('restaurant', 'pub', 'cafe')) |>
  osmdata_sf() |>
  getElement('osm_points')
foodDrink <- foodDrink[!is.na(foodDrink$amenity), ]
iconSet <- awesomeIconList(
  pub = makeAwesomeIcon(
    icon = 'beer',
    library = 'fa',
    iconColor = 'gold',
    markerColor = 'red',
    iconRotate = 10
  ),
  cafe = makeAwesomeIcon(
    icon = 'coffee',
    library = 'ion',
    iconColor = '#000000',
    markerColor = 'blue',
    squareMarker = TRUE
  ),
  restaurant = makeAwesomeIcon(
    icon = 'cutlery',
    library = 'glyphicon',
    iconColor = 'rgb(192, 255, 0)',
    markerColor = 'darkpurple',
    spin = TRUE,
    squareMarker = FALSE
  )
)
leaflet(foodDrink) |>
  addTiles() |>
  addAwesomeMarkers(icon = ~iconSet[amenity],
                    group = ~amenity) |>
  addLegendAwesomeIcon(iconSet = iconSet,
                       orientation = 'horizontal',
                       title = htmltools::tags$div(
                         style = 'font-size: 20px;',
                         'Horizontal Legend'),
                       labelStyle = 'font-size: 16px;',
                       position = 'bottomright',
                       group = 'Horizontal Legend') |>
  addLegendAwesomeIcon(iconSet = iconSet,
                       orientation = 'vertical',
                       marker = FALSE,
                       title = htmltools::tags$div(
                         style = 'font-size: 20px;',
                         'Vertical Legend'),
                       labelStyle = 'font-size: 16px;',
                       position = 'bottomright',
                       group = 'Vertical Legend') |>
  addLayersControl(baseGroups = sprintf('%s Legend', 
                                        c('Horizontal', 'Vertical')),
                   overlayGroups = c('pub', 'cafe', 'restaurant'),
                   options = layersControlOptions(collapsed = FALSE))

[CRAN] [github]

BULK INSERT statements

The fastest method is to use BULK INSERT statements with the data written to a file on the machine where the SQL Server resides. This requires that you have access/permissions to transfer the file to the remote host’s local filesystem and the server can access that location.

We can make use of the DBI::sqlCreateTable to generate the table schema and make some edits to it (optional) and then create the table for import.

library(DBI)
library(data.table)
library(nycflights13)
data("flights")
set.seed(88)
con <- ANSI()
flights <- flights[sample.int(nrow(flights), 1000000, replace = TRUE),]
fwrite('flights.csv')
# Take a guess at the table schema and write it
dbCreateTable(conn = con, name = 'dbo.TableName', fields = flights)c

A handy trick for generating code that you can edit for the schema and submit with dbExecute is

writeClipboard(sqlCreateTable(con = con, table = SQL('dbo.TableName'), 
               fields = flights, row.names = FALSE))

For this example, the file is written to a temporary file with field separators and line endings that match the defaults for BULK INSERT. The order of the data columns in the file needs to match the order of columns in the table created.

# Create a temporary file
folder <- '//server/folder'
tmp <- tempfile(tmpdir = folder, fileext = '.txt')
# Headers are not accepted and BULK INSERT assumes you have the data columns
# in the same order as the table columns
fwrite(flights, tmp, sep = '\t', col.names = FALSE)
# Execute Bulk Insert on the MS SQL Server
dbExecute(con,
          sqlInterpolate(con,
                         "
  BULK INSERT dbo.TableName
  FROM ?tmp
  WITH
  (
    FIELDTERMINATOR ='\t'
    , ROWTERMINATOR = '\n'
  )", tmp = tmp)
)

bcp Utility

If you are not able to write the file to a location that the SQL Server instance can access with the BULK INSERT statement, you can use the bulk copy program utility (bcp). bcp does not require knowledge of T-SQL and offers a few more options to control the import process.

The full documentation is provided here: bcp Utility.

bcp will need to be installed on your local machine and added to the system path. Using that same temp file and schema that was generated earlier, you can invoke bcp CLI with:

system2('bcp', args = c('schema.TableName',
                        'in', tmp,
                        '-S', 'server',
                        '-d', 'database',
                        '-t',
                        '-r', '\n',
                        '-c',
                        '-T'))

The documentation for the arguments can be found in the aformentioned documentation. This example uses trusted authentication, ‘\t’ as the column/field separators and ‘\n’ as the row/line terminators.

bcputility

The bcputility provides a wrapper to the bcp command line program that has some useful argument defaults, and abstracts away the file I/O and schema creation. We can now have fast writes of large imports with one line of code.

library(bcputility)
bcpImport(flights, server = server, database = database, table = 'flights1')

We can customize how data is passed with the batchsize and packetsize arguments.

bcpImport(flights, server = server, database = database, table = 'flights1',
          batchsize = 50000, packetsize = 4096*2)

Arguments can be passed to system2 with ... so we can check the results of the import process.

bcpImport(flights, server = server, database = database, table = 'flights1',
          batchsize = 50000, packetsize = 4096*2, 
          stdout = FALSE, # suppress printing to console
          stderr = 'import-flights-error.txt' # write errors to file
          )

If you need to change the default terminators, because the data includes tabs or newlines:

bcpImport(flights, server = server, database = database, table = 'flights1',
          batchsize = 50000, packetsize = 4096*2, 
          stdout = FALSE, # suppress printing to console
          stderr = 'import-flights-error.txt' # write errors to file
          fieldterminator = '|',
          rowterminator = '\r\n|\r\n'
          )

You can switch to sql authentication which you might need if writing to a database on Azure or trusted connections are not allowed.

bcpImport(flights, server = server, database = database, table = 'flights1',
          batchsize = 50000, packetsize = 4096*2, 
          stdout = FALSE, # suppress printing to console
          stderr = 'import-flights-error.txt' # write errors to file
          fieldterminator = '|',
          rowterminator = '\r\n|\r\n'
          username = 'myname',
          password = 'mypassword'
          )

Benchmarks

Benchmarks were performed with a local installation of SQL Server Express.

library(DBI)
library(data.table)
library(nycflights13)
data("flights")
set.seed(82)
flights <- flights[sample.int(nrow(flights), 1000000, replace = TRUE),]
server <- 'localhost\\SQLEXPRESS'
database <- 'Main'
con <- DBI::dbConnect(odbc::odbc(),
                      Driver = "SQL Server",
                      Server = server,
                      Database = database)
results <- microbenchmark::microbenchmark(
  bcpImport1000 = {
    bcpImport(flights,
              server = server,
              database = database,
              table = 'flights1',
              overwrite = TRUE,
              stdout = FALSE)
    },
  bcpImport10000 = {
    bcpImport(flights,
              server = server,
              database = database,
              table = 'flights2',
              overwrite = TRUE,
              stdout = FALSE,
              batchsize = 10000)
  },
  bcpImport50000 = {
    bcpImport(flights,
              server = server,
              database = database,
              table = 'flights3',
              overwrite = TRUE,
              stdout = FALSE,
              batchsize = 50000)
  },
  dbWriteTable = {
    DBI::dbWriteTable(con, name = 'flights4', flights, overwrite = TRUE)
    },
  times = 30L
)

The following demonstrates maintaining atomicity through an application that allows the user to re-allocate resources to 4 containers. Any container can transfer resources to another container but the amount must be greater than 0 and less than what is currently in the container that is losing resources. The condition that should always be met is that the sum of the resources should equal 100. The full application is at the end of the post for reference.

Create a Database

For the example, a database is created with a table that stores the amount of resources in each container. The total amount of resources available is limited to 100 and is pre-populated with initial values. A constraint has been placed that will be important later on.

library(DBI)
library(RSQLite)
con <- dbConnect(RSQLite::SQLite(), "allocations.sqlite")
dbExecute(con, 
  'CREATE TABLE Containers (Container int, Amount float, CHECK(Amount >= 0))'
)
dbExecute(con, 'INSERT INTO Containers (Container, Amount) VALUES(1, 10)')
dbExecute(con, 'INSERT INTO Containers (Container, Amount) VALUES(2, 20)')
dbExecute(con, 'INSERT INTO Containers (Container, Amount) VALUES(3, 30)')
dbExecute(con, 'INSERT INTO Containers (Container, Amount) VALUES(4, 40)')
dbGetQuery(con, 'SELECT Container, Amount FROM Containers')

Re-allocate Resources with Independent SQL Statements

The simplest approach is to execute two statements on the table in series. Using some server-side logic you can control that minimum and maximum amounts (roll your own logic with if/else statements and showNotification or showModal or check out shinyvalidate). As long as both of these statements execute, the application will perform as intended.

dbExecute(
  con,
  sqlInterpolate(
    con,
    'UPDATE Containers SET Amount = Amount + ?TransferAmount
                                     WHERE Container = ?ToContainer',
    TransferAmount = input$Amount,
    ToContainer = input$To
  )
)
dbExecute(
  con,
  sqlInterpolate(
    con,
    'UPDATE Containers SET Amount = Amount - ?TransferAmount
                                     WHERE Container = ?FromContainer',
    TransferAmount = input$Amount,
    FromContainer = input$From
  )
)

Because the database and application interactions are simple, the chance of an error occuring is relatively small (maybe not that small, network/connectivity errors are common enough). Depending on the use case, you may want to put some calculations in between those two statements, create more complicated database interactions, or execute some side effects. Any additions increase the risk of failure which can lead to results such as this:

The first statement executed but the second one that would balance the resources was never run due to an error. There are some ways to handle this on the database side which would prevent data loss (different topic and can be extremely complicated). To handle this exception, when one statement fails all statements should fail. This is the concept of a transaction and can be handled on the application side in shiny.

Re-allocate Resources with a Transaction

Start a transaction with dbBegin that will wrap the following database interactions into a single statement. There are three possible outcomes to close the transaction: dbCommit will make the changes, dbRollback will cancel any changes, and any closing of the connection will also cancel the changes. tryCatch is used to handle the errors cleanly (an error will crash the application) and you can also use the error message to alert the user what went wrong.

tryCatch({
  dbBegin(con)
  dbExecute(
    con,
    sqlInterpolate(
      con,
      'UPDATE Containers SET Amount = Amount + ?TransferAmount
                                     WHERE Container = ?ToContainer',
      TransferAmount = input$Amount,
      ToContainer = input$To
    )
  )
  dbExecute(
    con,
    sqlInterpolate(
      con,
      'UPDATE Containers SET Amount = Amount - ?TransferAmount
                                     WHERE Container = ?FromContainer',
      TransferAmount = input$Amount,
      FromContainer = input$From
    )
  )
  dbCommit(con)
}, error = function(e) {
  dbRollback(con)
  e
})

Handling Invalid Values

Now the user can enter invalid values and we can safely prevent them from putting the database into an undesirable state. We can rely on the database to alert the user with the error (that is the CHECK constraint that was placed during creation of the database). You can also handle the check on the application side with input validation which works with a single user, but can trip up concurrent users when transactions happen simultaneously or close enough together that the client side values in shiny are not up to date–isolation is a separate part of ACID.

Full Code

library(shiny)
library(ggplot2)
library(DBI)
library(RSQLite)
make_reactive_trigger <- function() {
    rv <- reactiveValues(a = 0)
    list(
        depend = function() {
            rv$a
            invisible()
        },
        trigger = function() {
            rv$a <- isolate(rv$a + 1)
        }
    )
}
DBTrigger <- make_reactive_trigger()
con <- dbConnect(RSQLite::SQLite(), "allocations.sqlite")
dbExecute(con, 
  'CREATE TABLE Containers (Container int, Amount float, CHECK(Amount >= 0))')
dbExecute(con, 'INSERT INTO Containers (Container, Amount) VALUES(1, 10)')
dbExecute(con, 'INSERT INTO Containers (Container, Amount) VALUES(2, 20)')
dbExecute(con, 'INSERT INTO Containers (Container, Amount) VALUES(3, 30)')
dbExecute(con, 'INSERT INTO Containers (Container, Amount) VALUES(4, 40)')
initContainers <- dbGetQuery(con, 'SELECT Container, Amount FROM Containers')

ui <- fluidPage(

    sidebarLayout(
        sidebarPanel(
            tags$h5('Total Resources: 100'),
            selectInput('From', 'Transfer from:', 
                        choices = initContainers[['Container']]),
            selectInput('To', 'Transfer to:', 
                        choices = initContainers[['Container']][-1]),
            numericInput('Amount', 'Amount', min = 0, value = 0, 
                         max = initContainers[['Amount']][1]),
            actionButton('Submit', 'Submit')
        ),
        mainPanel(
           plotOutput("AllocationPlot")
        )
    )
)

server <- function(input, output, session) {
    Allocations <- reactive({
        DBTrigger$depend()
        dbGetQuery(con, 'SELECT Container, Amount FROM Containers')
    })
    #  Transferring to self is redundant
    observeEvent(input$From, {
        updateSelectInput(
            session, 
            'To', 
            choices = Allocations()[['Container']][
            !Allocations()[['Container']] %in% input$From])
    })
    # Limit tranfer amount
    # this will produce a popup warning but is not currently enforced 
    # server side
    # see shinyvalidate package if using bootstrap3
    observeEvent(Allocations(), {
        i <- Allocations()[['Container']] == input$From
        updateNumericInput(
            session, 'Amount',
            max = Allocations()[['Amount']][i])
    })
    observeEvent(input$Submit, {
        res <- tryCatch({
            dbBegin(con)
            # disallow using negative values
            stopifnot(input$Amount > 0)
            dbExecute(con,
                      sqlInterpolate(con,
                                     'UPDATE Containers 
                                     SET Amount = Amount + ?TransferAmount
                                     WHERE Container = ?ToContainer',
                                     TransferAmount = input$Amount,
                                     ToContainer = input$To)
            )
            dbExecute(con,
                      sqlInterpolate(con,
                                     'UPDATE Containers 
                                     SET Amount = Amount - ?TransferAmount
                                     WHERE Container = ?FromContainer',
                                     TransferAmount = input$Amount,
                                     FromContainer = input$From)
            )
            dbCommit(con)
        }, error = function(e) {
            dbRollback(con)
            e
            })
        if ( inherits(res, 'error') ) {
            showNotification(res$message)
        }
        DBTrigger$trigger()
    })
    # Show Latest Allocations
    output$AllocationPlot <- renderPlot({
        ggplot(Allocations()) +
            geom_col(aes(Container, Amount)) +
            labs(title = sprintf('Total Allocated: %d', 
                                 sum(Allocations()[['Amount']]))) +
            theme_bw()
    })
}
shinyApp(ui = ui, server = server)

The leaflet package in R has built-in functionality for creating color encoded geometries and annotating with color legends. Support is lacking in the area of providing the ability to encode data with sizes or symbology except for the case of circle markers. Size and symbology are an important part of data visualization on a map. Using the leaflegend package, you can add both to your leaflet maps without adding external css or javascript.

Adding Proportional Sizing to Symbols

To create the appropriately sized symbols, The makeSymbolsSize function can create a list of icons based on the output of sizeNumeric. The baseSize argument sets the center point size of the data scale to the mean of the values e.g. with values 1, 2, 3, 4, 5 and a base size of 10, the resultant size in pixels of the symbols are 3.33, 6.67, 10, 13.33, 16.67. The symbols can be added as icons to the map since they are svg elements. Some transparency is added here to show overlapping symbols.

To add a legend for the sizes, addLegendSize takes in the same values and uses the pretty function and breaks argument to create the scale. There may be some inconsistency between the number of breaks specified (leaflet internals also make use of the pretty function). It is easy to customize other aspects of the legend for appearance such as here: the color, symbol, and transparency are matched to the symbols and we align the legend items horizontally.

library(leaflet)
library(leaflegend)
data("quakes")
symbols <- makeSymbolsSize(
  values = quakes$depth,
  shape = 'diamond',
  color = 'red',
  fillColor = 'red',
  opacity = .5,
  baseSize = 10
)
leaflet() %>%
  addTiles() %>%
  addMarkers(data = quakes,
             icon = symbols,
             lat = ~lat, lng = ~long) %>%
  addLegendSize(
    values = quakes$depth,
    color = 'red',
    fillColor = 'red',
    opacity = .5,
    title = 'Depth',
    shape = 'diamond',
    orientation = 'horizontal',
    breaks = 5)

Encoding Color and Size

A helper function addSymbolsSize simplifies the above code and one can use a palette to generate colors. The symbols are switched to a plus sign to provide a smaller impact of area for overlapping points. The result is called double-encoding and is a way to emphasize differences in data. Because the Richter scale is on a logarithmic scale, the actual reading of magnitude was taken as ten to the power of.

numPal <- colorNumeric('viridis', 10^(quakes$mag))
leaflet(quakes) %>%
  addTiles() %>%
  addSymbolsSize(values = ~10^(mag),
                 lat = ~lat, 
                 lng = ~long,
                 shape = 'plus',
                 color = ~numPal(10^(mag)),
                 fillColor = ~numPal(10^(mag)),
                 opacity = .5,
                 baseSize = 1) %>%
  addLegendSize(
    values = ~10^(mag),
    pal = numPal,
    title = 'Magnitude',
    baseSize = 1,
    shape = 'plus',
    orientation = 'horizontal',
    opacity = .5,
    fillOpacity = .3,
    position = 'bottomleft',
    breaks = 5)

Split Color and Size Encodings

It is also possible to color encode and size encode with different values. Using a palette function from the leaflet package, the color/fillColor arguments can be used to base the color encoding on a different vector of data than the values argument which is for size.

numPal <- colorNumeric('viridis', quakes$mag)
leaflet(quakes) %>%
  addTiles() %>%
  addSymbolsSize(values = ~depth,
                 lat = ~lat, 
                 lng = ~long,
                 shape = 'plus',
                 color = 'black',
                 fillColor = ~numPal(mag),
                 opacity = .5,
                 baseSize = 10) %>%
  addLegendSize(
    values = quakes$depth,
    color = 'black',
    title = 'Depth',
    shape = 'plus',
    orientation = 'horizontal',
    opacity = .5,
    fillOpacity = 0,
    breaks = 5,
    position = 'bottomright') %>%
  addLegendNumeric(
    pal = numPal, 
    title = 'Magnitude',
    shape = 'stadium',
    values = quakes$mag, 
    fillOpacity = .5,
    decreasing = TRUE,
    position = 'bottomright')
  

Size Legend Options

Specifying color and fillColor will override any palette function that is provided. Below are examples of all the different configurations for the legend. The symbols are also available for makeSizeIcons to match the desired legend.

numPal <- colorNumeric('viridis', quakes$depth)
leaflet() %>%
  addTiles() %>%
  addLegendSize(
    values = quakes$mag,
    color = 'black',
    title = 'Magnitude',
    labelStyle = 'margin: auto;',
    shape = 'cross',
    orientation = 'horizontal',
    opacity = .7,
    numberFormat = function(x) {
     prettyNum(x, big.mark = ",", scientific = FALSE, digits = 3)},
    breaks = 5,
    position = 'topright') %>%
  addLegendSize(
    values = quakes$mag,
    color = 'black',
    fillColor = 'transparent',
    title = 'Magnitude',
    labelStyle = 'margin: auto;',
    shape = 'cross',
    orientation = 'horizontal',
    opacity = .7,
    numberFormat = function(x) {
     prettyNum(x, big.mark = ",", scientific = FALSE, digits = 3)},
    breaks = 5,
    position = 'topright') %>%
  addLegendSize(
    values = quakes$depth,
    pal = numPal,
    title = 'Depth',
    labelStyle = 'margin: auto;',
    shape = c('cross'),
    orientation ='horizontal',
    opacity = .7,
    color = 'black',
    breaks = 5,
    position = 'topright') %>%
  addLegendSize(
    values = quakes$depth,
    pal = numPal,
    title = 'Depth',
    labelStyle = 'margin: auto;',
    shape = c('cross'),
    orientation ='horizontal',
    opacity = .7,
    fillColor = 'black',
    breaks = 5,
    position = 'topright') %>%
  addLegendSize(
    values = quakes$depth,
    pal = numPal,
    title = 'Depth',
    labelStyle = 'margin: auto;',
    shape = c('cross'),
    orientation ='horizontal',
    opacity = .7,
    breaks = 5,
    position = 'topright')

[CRAN] [github]

leaflegend allows the user to add images to legends, style the labels of the legend items, change orientation of the legend items, use different symbologies, and style axis ticks. Syntax and style is consistent with the leaflet package to lower the mental overhead for new users and the legends are outputs from leaflet::addControl to ensure interoperability.

Custom Images in Legends

Image files already are supported for mapping using the icon series of functions per documentation. addLegendImage accepts png, jpg, and svg data URIs and encodes and embeds them into the legend.

library(leaflet)
library(leaflegend)
data("quakes")
# from https://rstudio.github.io/leaflet/markers.html
quakes1 <- quakes[1:10,]
leafIcons <- icons(
  iconUrl = ifelse(quakes1$mag < 4.6,
                   "http://leafletjs.com/examples/custom-icons/leaf-green.png",
                   "http://leafletjs.com/examples/custom-icons/leaf-red.png"
  ),
  iconWidth = 38, iconHeight = 95,
  iconAnchorX = 22, iconAnchorY = 94,
  shadowUrl = "http://leafletjs.com/examples/custom-icons/leaf-shadow.png",
  shadowWidth = 50, shadowHeight = 64,
  shadowAnchorX = 4, shadowAnchorY = 62
)

leaflet(data = quakes1, width = '100%') %>% addTiles() %>%
  addMarkers(~long, ~lat, icon = leafIcons) %>%
  addLegendImage(images = c("http://leafletjs.com/examples/custom-icons/leaf-green.png",
                            "http://leafletjs.com/examples/custom-icons/leaf-red.png"),
                 labels = c('Green', 'Red'),width = 38, height = 95,
                 orientation = 'vertical',
                 title = htmltools::tags$div('Leaf',
                                             style = 'font-size: 24px; text-align: center;'),
                 position = 'topright')

Creating SVG Map Symbols

A helper function is provided to create svg data URIs for commonly used symbols – rect, circle, triangle, plus, cross, star and stadium. Beyond the named arguments for styling the symbol, you can use ... to pass arguments to modify the svg. I would recommend taking a look at MDB Web Docs to see all the available options.

redx <- makeSymbol('cross', width = 100, height = 100, color = 'black', fillColor = 'red',
           opacity = .7, fillOpacity = .5)
htmltools::img(src = redx)

Images on disk can be mixed with the symbols and displayed. To make your own symbol, create a character string with data:image/svg+xml,<svg>...</svg> and add the class ‘svgURI’.

leaflet(data = quakes1, width = '100%') %>% addTiles() %>%
  addMarkers(~long, ~lat, icon = leafIcons) %>%
  addLegendImage(images = list("http://leafletjs.com/examples/custom-icons/leaf-green.png",
                               "http://leafletjs.com/examples/custom-icons/leaf-red.png",
                               redx),
                 labels = c('Green', 'Red', 'Cross'), 
                 width = c(38, 38, 40), 
                 height = c(95, 95, 40),
                 orientation = 'vertical',
                 title = htmltools::tags$div('Leaf',
                                             style = 'font-size: 24px; text-align: center;'),
                 position = 'topright')

The map symbols can be used on leaflet maps as well. Create a list of the items and create them as icons as you would for image files or from icon libraries.

shapes <- c('rect', 'circle', 'triangle', 'plus', 'cross', 'star')
symbols <- setNames(Map(f = makeSymbol
               ,shape = shapes
               ,fillColor = c('blue', 'red', 'green', 'yellow', 'orange', 'purple')
               ,color = 'black'
               ,opacity = 1
               ,fillOpacity = .5
               ,height = 24
               ,width = 24
               ,'stroke-width' = 2), shapes)
quakes[['symbol']] <- sample(shapes, nrow(quakes), replace = TRUE)

leaflet(data = quakes[sample(seq_len(nrow(quakes)), 25),], width = '100%') %>% addTiles() %>%
  addMarkers(
    ~ long,
    ~ lat,
    icon = ~ icons(
      iconUrl = symbols[symbol],
      iconWidth = 20,
      iconHeight = 20
    )
  ) %>%
  addLegendImage(
    images = symbols,
    labels = shapes,
    width = 50,
    height = 50,
    orientation = 'vertical',
    title = htmltools::tags$div('Symbol',
                                style = 'font-size: 24px; text-align: center;'),
    position = 'topright'
  )

Update: Requires leaflegend >= 1.0.0

shapeColorPal <- colorFactor(c('blue', 'red', 'green', 
                               'yellow', 'orange', 'purple'),
                             shapes)
leaflet(data = quakes[sample(seq_len(nrow(quakes)), 25),], width = '100%') %>% 
  addTiles() %>%
  addSymbols(
    lng = ~long,
    lat = ~lat,
    values = ~symbol, color = 'black', 
    fillColor = ~shapeColorPal(symbol),
    fillOpacity = .5,
    width = 24,
    height = 24
  ) %>%
  addLegendSymbol(
    pal = shapeColorPal,
    values = ~symbol,
    color = 'black',
    fillOpacity = .5,
    width = 50,
    height = 50,
    orientation = 'vertical',
    title = htmltools::tags$div('Symbol',
                                style = 'font-size: 24px; text-align: center;'),
    position = 'topright'
  )

Customizing Leaflet Legends with Palettes

The addLegend* functions take palettes generated from the leaflet package and uses them to create legends with greater flexibility. For instance, using differently symbology for points is possible by specifying a different shape. You can control the opacity of the outline and fill so that it matches what is displayed on the map. Position the legend elements to be horizontal or vertical and control the text styling of the title and the label elements.

binPal <- colorBin('Set1', quakes$mag)
symbols <- lapply(binPal(quakes$mag)
                  ,makeSymbol
                  ,shape = 'triangle'
                  ,opacity = 1
                  ,fillOpacity = .5
                  ,height = 24
                  ,width = 24
                  ,'stroke-width' = 1)
leaflet(width = '100%') %>%
  addTiles() %>%
  addMarkers(
    data = quakes,
    lat = ~ lat,
    lng = ~ long,
    icon = ~icons(
      iconUrl = symbols,
      iconWidth = 10,
      iconHeight = 10
    )
  ) %>%
  addLegendBin(
    pal = binPal,
    values = quakes$mag,
    position = 'bottomleft',
    title = 'horizontal',
    shape = 'triangle',
    opacity = 1,
    fillOpacity = .2,
    labelStyle = 'font-size: 18px; font-weight: bold;',
    orientation = 'horizontal',
    layerId = 'horizontal'
  ) %>%
  addLegendBin(
    pal = binPal,
    values = quakes$mag,
    position = 'bottomright',
    title = 'vertical',
    shape = 'triangle',
    opacity = 1,
    fillOpacity = .2,
    orientation = 'vertical',
    layerId = 'vertical'
  ) %>%
  addLegend(pal = binPal,
            values = quakes$mag,
            title = 'addLegend',
            layerId = 'addLegend')

[CRAN] [github]

library(RSQLite)
library(DBI)
con <- dbConnect(RSQLite::SQLite(), ":memory:")
dbExecute(con, 'CREATE TABLE mytable (col1 int, col2 varchar(10));')

## [1] 0

Check that the table exists now.

dbListTables(con)

## [1] "mytable"

Add a single row to the table to check that we can insert.

dbExecute(con, 'INSERT INTO mytable ([col1], [col2]) VALUES (1, "b");"')

## [1] 1

dbGetQuery(con, 'SELECT col1, col2 FROM mytable')

##   col1 col2
## 1    1    b

So now we have a table in the database and we can write to it. When the shiny application loads, we will want to show the user what is in the table.

mytableinshiny <- reactive({
  dbGetQuery(con, 'SELECT col1, col2 from mytable')
})
mytableinshiny()

##   col1 col2
## 1    1    b

This works great and now we can use the data from the database to do whatever we need it to do in the shiny application. If we create the following action, the function does the necessary side effect of writing to the database but unless the user reloads the application mytableinshiny does not update in the application.

observeEvent(input$writetodb, {
  sql <- sqlInterpolate(con, 'INSERT INTO mytable ([col1], [col2]) VALUES (col1, ?col2);"',
                        col1 = input$col1, col2 = input$col2)
  dbExecute(con, sql)
})

mytableinshiny()

##   col1 col2
## 1    1    b

After the database insertion, we need a way to inform shiny to update the reactive data.frame. We can use a reactive trigger to “push” a button that lets shiny know that the database has changed and it should re-execute the SELECT query.

makereactivetrigger <- function() {
  rv <- reactiveValues(a = 0)
  list(
    depend = function() {
      rv$a
      invisible()
    },
    trigger = function() {
      rv$a <- isolate(rv$a + 1)
    }
  )
}
dbtrigger <- makereactivetrigger()

The trigger is now an object that has a couple of functions to pass messages around. We need to set the reactive value to re-execute so add the depend function and after the database interaction executes we add the trigger function. Also, it’s good practice to use sqlInterpolate to help prevent sql injection attacks.

mytableinshiny <- reactive({
  dbtrigger$depend()
  dbGetQuery(con, 'SELECT col1, col2 from mytable')
})
observeEvent(input$writetodb, {
  sql <- sqlInterpolate(con, 'INSERT INTO mytable ([col1], [col2]) VALUES (?col1, ?col2)',
                        col1 = input$col1, col2 = input$col2)
  dbExecute(con, sql)
  dbtrigger$trigger()
})

Within the app, we put the data in the shiny input forms and hit the write to database action button when ready.

mytableinshiny()

##   col1 col2
## 1    1    b
## 2    2    a

Now when the database is updated the shiny application syncs to what is in the database after the insertion.

Here’s a toy example to play with:

library(shiny)
library(RSQLite)
library(DBI)
makereactivetrigger <- function() {
    rv <- reactiveValues(a = 0)
    list(
        depend = function() {
            rv$a
            invisible()
        },
        trigger = function() {
            rv$a <- isolate(rv$a + 1)
        }
    )
}
dbtrigger <- makereactivetrigger()
con <- dbConnect(RSQLite::SQLite(), ":memory:")
dbExecute(con, 'CREATE TABLE mytable (col1 int, col2 varchar(10));')
ui <- fluidPage(
    numericInput('col1', 'col1', value = 1L, step = 1L),
    textInput('col2', 'col2', value = 'a'),
    actionButton('writetodb', 'Save'),
    tableOutput('dbtable')
)
server <- function(input, output) {
    mytableinshiny <- reactive({
        dbtrigger$depend()
        dbGetQuery(con, 'SELECT col1, col2 from mytable')
    })
    observeEvent(input$writetodb, {
        sql <- sqlInterpolate(con, 'INSERT INTO mytable ([col1], [col2]) VALUES (?col1, ?col2)',
                              col1 = input$col1, col2 = input$col2)
        dbExecute(con, sql)
        dbtrigger$trigger()
    })
    output$dbtable <- renderTable({
        mytableinshiny()
    })
}
shinyApp(ui = ui, server = server)

Introduction

Shiny modules provide a great way to organize and container-ize your code for building complex Shiny applications as well as protecting namespace collisions. I highly recommend starting with the excellent documentation from Rstudio. In this post, I am going to cover how to implement modules with insertUI/removeUI so that you DRY, clear server-side overhead, and encapsulate duplicative-ish shiny input names in their own namespace.

Normally when developing an application, each input provides a unique parameter for the output and it is specified by a unique ID. The example below illustrates a shiny app that allows the end user to specify the variables for regression.

library(shiny)
data(mtcars)
cols <- sort(unique(names(mtcars)[names(mtcars) != 'mpg']))
ui <- fluidPage(
    wellPanel(
    fluidRow(
        column(4,
               tags$h3('Build a Linear Model for MPG'),
               selectInput('vars',
                           'Select dependent variables',
                           choices = cols,
                           selected = cols[1:2],
                           multiple = TRUE)),
        column(4, verbatimTextOutput('lmSummary')),
        column(4, plotOutput('diagnosticPlot'))
    )
  )
)
server <- function(input, output) {
    lmModel <- reactive({lm(sprintf('mpg ~ %s', paste(input$vars, collapse = '+')),
                  data = mtcars)})
    output$lmSummary <- renderPrint({
        summary(lmModel())
    })

    output$diagnosticPlot <- renderPlot({
        par(mfrow = c(2,2))
        plot(lmModel())
    })
}
shinyApp(ui = ui, server = server)

There is no need to worry about namespace collisions here because you can directly control the unique-ness of each input control. Note: If you accidentally duplicate the id, Shiny is not going to tell you that from the R console. If you open up the browser devtools, you will find an error like this:

Creating insertUI/removeUI Modules

Now, one linear model is great to start, but I want to try out several different models with different variables. I could select the variables, take a screenshot of each model, and piece them all together later but I’m trying to make it much easier for the end user. Wrapping the app above into a module requires a UI function. The NS function is a convenience function to create a namespace for the input IDs. In short, when input IDs are created later on they will be pre-fixed with lmModelid.

lmUI <- function(id) {
  ns <- shiny::NS(id)
  shiny::uiOutput(ns("lmModel"))
}

This particular module UI may look a bit sparse to other examples. The UI that the end user sees is going to be generated later on with renderUI. All that this UI needs to do is set the namespace.

Next, the server code needs to be wrapped into a server module. The UI and server code is going to be combined for use with renderUI. I also added in a delete button that will be the input for removing UI controls. The rendered UI is also wrapped with a div id. To keep track of each UI Controls, I’m using environment(ns)[['namespace']] which is a fancy way to pull out the namespace from session$ns. environment gets the environment (space to look in for values; similar to namespace) of ns which is storing the namespace id. Environments are an advanced concept in R which you can find details on at from Advanced R from Hadley Wickham and also from R Language Definition

lmModelModule <- function(input, output, session) {
  lmModel <- reactive({
    lm(sprintf('mpg ~ %s',paste(input$vars, collapse = '+')), data = mtcars)
    })
  output[['lmModel']] <- renderUI({
    ns <- session$ns
    tags$div(id = environment(ns)[['namespace']],
    tagList(
      wellPanel(
        fluidRow(
            column(3,
                   tags$h3('Build a Linear Model for MPG'),
                   selectInput(ns('vars'),
                               'Select dependent variables',
                               choices = cols,
                               selected = cols[1:2],
                               multiple = TRUE)),
            column(4, 
                   renderPrint({summary(lmModel())})
            ),
            column(4, 
                   renderPlot({par(mfrow = c(2,2))
                               plot(lmModel())})
                     ),
            column(1,
                   actionButton(ns('deleteButton'),
                                '',
                                icon = shiny::icon('times'),
                                style = 'float: right')
            )
        )
      )
    )
    )
  })
}

Dynamic UI/Server Logic

The modules can be called just as functions can be called. For ease, just place the module code at the top of the shiny application script outside of the main server/ui functions. The main shiny functions below are even shorter than the workhorse module functions. Even in a small application you can start to see the benefit of “modularizing” code!

The majority of the code in server is just setting up handling for the module IDs. The actionButton increments by 1 each time that it is clicked so I’m using it as an ID number. The id tag is doing double duty here: providing the namespace for module UI and for the div tag so that we can remove it later on. After calling the module, you will want to create an action that will respond to deleting the module. The last observeEvent will create that action and it will persist with the correct id.

ui <- fluidPage(
    br(),
    actionButton('addButton', '', icon = icon('plus'))
)
server <- function(input, output) {
    observeEvent(input$addButton, {
        i <- sprintf('%04d', input$addButton)
        id <- sprintf('lmModel%s', i)
        insertUI(
            selector = '#addButton',
            where = "beforeBegin",
            ui = lmUI(id)
        )
        callModule(lmModelModule, id)
        observeEvent(input[[paste0(id, '-deleteButton')]], {
            removeUI(selector = sprintf('#%s', id))
            remove_shiny_inputs(id, input)
        })
    })
}
shinyApp(ui = ui, server = server)

Cleaning up Server Side

removeUI will delete the contents on the client side, but the inputs will still exist on the server side. Currently, removing the inputs on the server side is not implemented in the shiny package. A couple of work-arounds have been provided here and here.

remove_shiny_inputs <- function(id, .input) {
  invisible(
    lapply(grep(id, names(.input), value = TRUE), function(i) {
      .subset2(.input, "impl")$.values$remove(i)
    })
  )
}

I used the latter to pass that all important id to look up all inputs in that namespace and remove them. Inputs are protected from directly using input[[inputName]] <- NULL to delete them. For the outputs on the server side, I haven’t been able to find that much documentation on what happens to it. I know that they still exist as at least a named entry on the server side. According to this closed issue, it is possible to remove them, but it doesn’t appear their name slots go away. Debugging and using outputOptions still listed the output, but setting the output to NULL will delete them from what the user sees on the shiny application.

Final Thoughts

Modules, insertUI, and removeUI have added some very impressive features to Shiny. It has opened up a much more on-the-fly interface for Shiny developers. I’m hoping development around these ideas continue. My first crack at this, I didn’t use the NS framework at all, but essentially used the same method so there is more than one way to do this. Using NS will save you leg work. Here is an example of my first attempt:

observeEvent(input$add, {
  i <- input$add
  id <- sprintf('%04d', i)
  inputID <- sprintf('input-%s', id)
  insertUI(
    selector = "#add",
    ui = tags$div(id = inputID,
                  numericInput(id, 'A number')
    )
  )
})

Possible enhancment: In the above code, I was using integers from the action button increment so that I could easily see that Shiny was doing what I expected it to do. An enhancement would be to generate something like a guid so that you wouldn’t have to worry about what happens when multiple users in the same app are clicking. This might not be needed if the action button increments are per user per session. I still have some homework to do on the namespacing in Shiny and client/server data persistence.

DBI::dbWriteTable(con, 
                  DBI::Id(schema = "schema", table = "tablename"), 
                  df)

But the code above will return a strange error:

After some investigation I found a workaround to be able to write the table. For non-default schemas, a “_” needs to in the table name for it to work.

DBI::dbWriteTable(con, 
                  DBI::Id(schema = "schema", table = "tablename_"), 
                  df)

This really isn’t ideal for naming conventions so using the t-sql command sp_rename will rename the table to what I originally wanted.

DBI::dbWriteTable(con, 
                  DBI::Id(schema = "schema", table = "tablename"), 
                  df)
DBI::dbGetQuery(con, "USE database;
EXEC sp_rename '[schema].[tablename_]', 'tablename';")

I ran into the same issues for overwriting tables as well but a workflow for doing the same is simply to use sp_rename a couple of times.

DBI::dbGetQuery(con, "USE database;
EXEC sp_rename '[schema].[tablename]', 'tablename_';")
DBI::dbWriteTable(con, 
                  DBI::Id(schema = "schema", table = "tablename_"), 
                  df, 
                  overwrite = TRUE)
DBI::dbGetQuery(con, "USE database;
EXEC sp_rename '[schema].[tablename_]', 'tablename';")

• Raspberry Pi with standard setup (SD card, case, etc.)
• Adafruit AM2302 (wired DHT22) temperature-humidity sensor
• Soldering Iron
• Female Pin Headers
• Small piece of wood

Materials to be used

Final Product

I mostly followed the tutorial found here. The majority of the work in this post is not using R. Instead of rebuilding everything, I wanted to build off of content that has made and sensor readings are handled a bit better by a low level language (C is used here).

Install wiringPi

We are going to start with the assumption that you have already set up the raspberry pi and soldered the sensor to the GPIO. An excellent repository already exists at http://wiringpi.com/. It provides a C interface to the GPIO that will prevent us from having to write any of the low level code. I’m going to SSH into my headless pi and install the wiringPi program with the following commands. In the examples, you can build and run a program to check if you are getting good readings.

git clone git://git.drogon.net/wiringPi
cd wiringPi
./build
cd examples
make rht03
./rht03

You should see readings from the sensor now. Type CTRL+c to quit the program.

Set up a MYSQL Server

In this step we are going to install MYSQL server and create some security around it. When you see ‘username’ or ‘password’ those are meant for you to replace with your own credentials. Instead of only using root to access the server with elevated priviliges, I am going to grant all privileges to a different user, but only when on the ‘localhost’, Essentially, you need to remote in currently to access the server with your ‘user’ credentials. Last, log back into the server with your new user identity for the next step.

sudo apt-get install mysql-server
sudo apt-get install default-libmysqlclient-dev
sudo mysql_secure_installation
sudo mysql
GRANT ALL PRIVILEGES ON *.* TO 'username'@'localhost' IDENTIFIED BY 'password';
\q
mysql -u 'username' -p

Set up a Database

Now, let’s create a database and a table with the time in UNIX integer time and two other columns for the sensor readings that we want to record.

create database Monitoring;
use Monitoring;
create table Climate (ComputerTime INTEGER UNSIGNED,Temperature DECIMAL(5,1), Humidity DECIMAL(5,1));

Run the program to read and write data

You will need to download this file:

th.c

Change the 'root' and 'password' credentials to match the user that you set up earlier. You will need to copy over the Makefile and change some flags so that the program knows where to find some of the drivers that it needs.

cp wiringPi/examples/Makefile ~/raspberrypi/monitor/Makefile
sudo nano ~/raspberrypi/monitor/Makefile

Add the following lines to the file:

INCLUDE = -I/usr/local/include,/usr/include/mysql
LDFLAGS = -L/usr/local/lib,/usr/lib/arm-linux-gnueabihf -lmysqlclient -lpthread -lz -lm -lrt -ldl

Compile the program:

make ~/raspberrypi/monintor/th

You will now run the program that you altered and compiled. Use the & to run the program continuously in the background. The program will write the temperature and humidity every 60 seconds to the database.

./raspberrypi/monitor/th &

Set up R

This step is optional but good to have for troubleshooting. Later, I will be connecting remotely on my laptop instead of working in R on the raspberry pi.

sudo apt-get install r-base
sudo su - -e 'install.packages("DBI", "RMariaDB")'

Check Database Connection and Query

After a couple hours, you should have a good amount of data. I’m going to be connecting from my laptop so I’ll need to set up my user credentials with privileges to access over my LAN which to cover all ip addresses that get assigned use the % (wildcard) at the end of 192.168.1 (your LAN is already set to use this ip address numbering system).

GRANT ALL PRIVILEGES on *.* TO 'user'@'192.168.1.%' IDENTIFIED BY 'password';
FLUSH PRIVILEGES;
\q

Let’s make sure that the server has a port that we can access. If it’s not already in the my.conf file, open up the file with a text editor.

sudo nano /etc/mysql/my.cnf

Add the following lines to the file which opens up the default port 3306 for the mysql server and then bind to current IP address.

[msqld]
port=3306
bind-address=0.0.0.0

Restart the service for the changes to take effect.

sudo service mysql restart

You can log off the machine now. We don’t need to do anything else on the raspberry pi for now.

Access the Data Remotely

From RStudio on my laptop (while connected to my LAN), we’re going to open a connection to the database. You can specify the host as a DNS name that can be set up on your router’s administration portal or you can specify the IP address. I would recommend making the IP address static if you plan on using that method going forward. Since we stored the timestamp in UNIX integer form, we can convert it to POSIXct knowing that the origin of UNIX time is the start of the year 1970.

library(DBI)
library(ggplot2)
library(trstyles) # optional package for my styling of ggplot2 plots

con <- dbConnect(RMariaDB::MariaDB(), host = 'sensorpi', 
                 user = 'pi', password = 'password',
                 dbname = 'Monitoring')
query <- 'SELECT ComputerTime, Temperature, Humidity FROM Climate'
readings <- dbGetQuery(con, query)
readings[['ComputerTime']] <- as.POSIXct(readings[['ComputerTime']], 
                                         origin = '1970-01-01 00:00:00')

Plot the Data

Now that we have the data, let’s plot temperature against time to see what has been going on.

ggplot(readings) +
  geom_line(aes(ComputerTime, Temperature)) +
  scale_y_continuous(name = expression('Temperature ('*degree*'C)'),
                     sec.axis = sec_axis(~.*9/5+32, 
                                         name = 
                                           expression('Temperature ('*degree*'F)'))) +
  scale_x_datetime(name = '', date_breaks = '2 days') +
  theme_tr(base_size = 18) +
  theme(axis.text.x = element_text(angle = 90, vjust = .5))

It looks good for the most part, but we definitely have some outlier readings. I can see probably outliers at 30 degrees Celsius. I’m going to cut those off and take a second look.

readings[['Temperature']][readings[['Temperature']] > 30] <- NA
ggplot(readings) +
  geom_line(aes(ComputerTime, Temperature)) +
  scale_y_continuous(name = expression('Temperature ('*degree*'C)'),
                     sec.axis = sec_axis(~.*9/5+32, 
                                         name = 
                                           expression('Temperature ('*degree*'F)'))) +
  scale_x_datetime(name = '', date_breaks = '2 days') +
  theme_tr(base_size = 18) +
  theme(axis.text.x = element_text(angle = 90, vjust = .5))

You can see some patterns already existing within the data. Given how the weather patterns have been, adding in some outside temperature readings would provide some more insight into what is going on. I’ll dive into some more analysis in another post.

We can do the same for the relative humidity.

ggplot(readings) +
  geom_line(aes(ComputerTime, Humidity), color = '#9D5863') +
  scale_y_continuous(name = 'Relative Humidity (Rh)') +
  scale_x_datetime(name = '', date_breaks = '2 days') +
  theme_tr(base_size = 18) +
  theme(axis.text.x = element_text(angle = 90, vjust = .5))

readings[['Humidity']][readings[['Humidity']] > 50] <- NA
ggplot(readings) +
  geom_line(aes(ComputerTime, Humidity), color = '#9D5863') +
  scale_y_continuous(name = 'Relative Humidity (Rh)') +
  scale_x_datetime(name = '', date_breaks = '2 days') +
  theme_tr(base_size = 18) +
  theme(axis.text.x = element_text(angle = 90, vjust = .5))

And that’s it. You have your very own indoor climate monitoring system and time series data to play around with at home.

For various urban/transportation planning or market analysis, one will probably be interested in the possible areas that can be reached by road within a certain amount of time. A representation of that is called an isochrone. An isochrone is a spatial object typically a polygon or multipolygon that shows a geographic region that can reach a point within the specified travel time parameters. Programmatically in R, all we need to do is specific the latitude and longtitude of interest and the travel time.

library(osrm)
osrmIsochrone(c(-95.9345,41.2565), breaks = 10)

The osrm package has some options behind the scenes that are preset for you. The call above has set the server to the demo server (you can set up your own server for reliability) and it has set the mode of transportation to “driving”. To change the profile, you have to adjust the option “osrm.profile”. I’ve been able to use “driving”, “bike”, and “walk” so far. You can find more documentation here: OSRM Documentation and osrm Github.

I’ve created a shiny app to show an example of building a sharp interface for end users to easily specify the parameters and download the geojson or shapefile for other uses. The app is in showcase mode (code is at the bottom) so you can see what else is going on behind the scenes with the sf and leaflet package.

Link to application

• shiny gadget for fitting univariate distributions has been added

• added test function for distfun objects

• diagnostic plots now have better checks for distfun objects and lists of distfun objects

fitur on CRAN

fitur on CRAN

Continuous Distribution GOF Tests

library(fitur)

## Warning: replacing previous import 'vctrs::data_frame' by 'tibble::data_frame'
## when loading 'dplyr'

x <- rgamma(100, 1, 1)
fit <- fit_univariate(x, 'gamma')
ks_test(fit, x)

## 
## 	One-sample Kolmogorov-Smirnov test
## 
## data:  x
## D = 0.043386, p-value = 0.9918
## alternative hypothesis: two-sided

ad_test(fit, x)

## 
## 	Anderson-Darling test of goodness-of-fit
## 	Null hypothesis: distribution 'distfun[[2]]'
## 	Parameters assumed to be fixed
## 
## data:  x
## An = 0.27471, p-value = 0.9558

cvm_test(fit, x)

## 
## 	Cramer-von Mises test of goodness-of-fit
## 	Null hypothesis: distribution 'distfun[[2]]'
## 	Parameters assumed to be fixed
## 
## data:  x
## omega2 = 0.034495, p-value = 0.9599

In this excercise, I’m going to show how to automate some aspects of coding in shiny to speed up development. Traditionally, in user interface development, one has to explicitly type out each individual input argument. For small applications, this is justified and probably isn’t worth the time to automate the task. The first part goes over using functional programming to loop through data and utilize its characteristics to create the inputs. These same concepts will be used in the second part to do the same with the outputs of in the server file that one wants to manipulate. This requires a little more tweaking because of the nature of the logic in shiny, but you will see how greatly you can reduce the amount of code that needs to be written.

Looping Inputs

Below I’m using the diamonds dataset from the ggplot2 package. This dataset has several different data types in the data.frame where you can use base R functions to find the data types. Using control logic, it is easy to specify different shiny input funtions that you will only have to write once. I’ve included the id argument as a way to name the inputs and be able to call them later. mapply allows me to apply the build_shiny_input function to each column in the data.frame and tag the input with the name. Hint: When using mapply on shiny inputs, you need to specify SIMPLIFY = FALSE.

library(shiny)
library(shinythemes)
library(ggplot2)
library(trstyles) # to run code replace theme_tr()
data("diamonds")
set.seed(311)
diamonds[['randomGroups']] <- sample(as.character(1:5), 
                                     nrow(diamonds), 
                                     replace = TRUE)
build_shiny_input <- function(x, id) {
  if (is.double(x)) {
    sliderInput(id, id, min = min(x), max = max(x), value = c(min(x), max(x)))
  } else if (is.ordered(x)) {
    selectInput(id, id, choices = unique(sort(x)),
                selected = as.character(unique(sort(x))), multiple = TRUE)
  } else if (is.factor(x) | is.character(x)) {
    checkboxGroupInput(id, id, choices = sort(unique(x)),
                       selected = sort(unique(x)))
  } else if (is.integer(x)) {
    sliderInput(id, id, value = c(min(x),max(x)), 
                step = 1, min = min(x), max = max(x))
  } else {
    NULL
  }
}
shinyInputs <- mapply(diamonds, 
                      id = names(diamonds), 
                      FUN = build_shiny_input,
                      SIMPLIFY = FALSE)

UI

The above code can be rendered outside of the UI allowing the app to only have to render it once. Now I can put all 11 of the shiny inputs with one line of code which greatly reduces the complexity seen in the ui.

ui <- fluidPage(theme = 'flatly',
   
   titlePanel("Dynamic Shiny UI"),
   
   sidebarLayout(
      sidebarPanel(
         tagList(shinyInputs)
      ),
      
      mainPanel(
         h5("Generated Inputs"),
         textOutput("inputNames"),
         h5("Generated Outputs"),
         uiOutput("plots")
         
      )
   )
)

The next part is a little trickier. You can once again specify different plot types based on the data type from the diamonds dataset. I’m using the tagList function to encapsulate the plot and break tags. I’m using a little bit of rlang magic as well to convert the text id to a symbol and evaluating in the geom_ call.

Looping Outputs

render_plot_data <- function(inputName, shinyInput) {
  x <- diamonds[[inputName]]
  if (is.double(x)) {
    i <- x >= shinyInput[[inputName]][1] & x <= shinyInput[[inputName]][2]
    g <- ggplot(diamonds[i, ]) +
      geom_density(aes(!!sym(inputName))) +
      theme_tr() +
      theme(panel.background = element_rect(fill = 'transparent'),
            plot.background = element_rect(fill = 'transparent',
                                           color = NA))
    tagList(renderPlot(g), br())
  } else if (is.character(x) | is.factor(x)) {
    i <- x %in% shinyInput[[inputName]]
    g <- ggplot(diamonds[i, ]) +
      geom_bar(aes(!!sym(inputName))) +
      theme_tr() +
      theme(panel.background = element_rect(fill = 'transparent'),
            plot.background = element_rect(fill = 'transparent',
                                           color = NA))
    tagList(renderPlot(g), br())
  } else NULL
}

Server

To show that the input naming ids worked. The first part just renders the ids of the shiny inputs into text. renderUI can be used to not only create dynamic inputs but dynamic outputs as well. Using lapply now, you only need to pass in the shiny input id to be able to call to it in the render_plot_data function. Once again, you see how much you are able to hide the underlying complexity in the server.

server <- function(input, output) {
   reactDiamonds <- reactive({
     names(input)
   })
   output$inputNames <- renderText(reactDiamonds())
   observe({
     output$plots <- renderUI({
       lapply(names(input),
              shinyInput = input,
              render_plot_data)
     })
   })
}

End Product

And thats it! With just a little bit of code, you can do some powerful things with shiny. Let the data do the work. Resources for learning more are listed below with the full code to try out as well. Here’s a snapshot of the end product:

Further Reading

Creating a UI from a loop

Shiny Dynamic Number of Output Element Plots

Full Code

library(shiny)
library(shinythemes)
library(ggplot2)
data("diamonds")
set.seed(311)
diamonds[['randomGroups']] <- sample(as.character(1:5), 
                                     nrow(diamonds), 
                                     replace = TRUE)

build_shiny_input <- function(x, id) {
  if (is.double(x)) {
    sliderInput(id, id, min = min(x), max = max(x), value = c(min(x), max(x)))
  } else if (is.ordered(x)) {
    selectInput(id, id, choices = unique(sort(x)),
                selected = as.character(unique(sort(x))), multiple = TRUE)
  } else if (is.factor(x) | is.character(x)) {
    checkboxGroupInput(id, id, choices = sort(unique(x)),
                       selected = sort(unique(x)))
  } else if (is.integer(x)) {
    sliderInput(id, id, value = c(min(x),max(x)), 
                step = 1, min = min(x), max = max(x))
  } else {
    NULL
  }
}

render_plot_data <- function(inputName, shinyInput) {
  x <- diamonds[[inputName]]
  if (is.double(x)) {
    i <- x >= shinyInput[[inputName]][1] & x <= shinyInput[[inputName]][2]
    g <- ggplot(diamonds[i, ]) +
      geom_density(aes(!!sym(inputName))) +
      theme_bw() +
      theme(panel.background = element_rect(fill = 'transparent'),
            plot.background = element_rect(fill = 'transparent',
                                           color = NA))
    tagList(renderPlot(g), br())
  } else if (is.character(x) | is.factor(x)) {
    i <- x %in% shinyInput[[inputName]]
    g <- ggplot(diamonds[i, ]) +
      geom_bar(aes(!!sym(inputName))) +
      theme_bw() +
      theme(panel.background = element_rect(fill = 'transparent'),
            plot.background = element_rect(fill = 'transparent',
                                           color = NA))
    tagList(renderPlot(g), br())
  } else NULL
}

shinyInputs <- mapply(diamonds, 
                      id = names(diamonds), 
                      FUN = build_shiny_input,
                      SIMPLIFY = FALSE)

ui <- fluidPage(theme = 'flatly',
   
   titlePanel("Dynamic Shiny UI"),
   
   sidebarLayout(
      sidebarPanel(
         tagList(shinyInputs)
      ),
      
      mainPanel(
         h3("Generated Inputs"),
         textOutput("inputNames"),
         uiOutput("plots")
         
      )
   )
)

server <- function(input, output) {
   reactDiamonds <- reactive({
     names(input)
   })
   output$inputNames <- renderText(reactDiamonds())
   observe({
     output$plots <- renderUI({
       lapply(names(input),
              shinyInput = input,
              render_plot_data)
     })
   })
}

shinyApp(ui = ui, server = server)

Oftentimes, I run into difficulty trying to explain some of the concepts of statistical sampling with audiences that either have very limited or no understanding of statistics. Given that the majority of communication of analysis has to be digested in a 1-2 hour meeting, data visualization typically is the best route for communicating my methods.

One such case is unboxing how sampling works based on your presumed population and using that sampling to build a monte carlo simulation. I’m a big fan of interactive visualizations or animations that break down in detail the underpinnings of an analysis. The basis of this post is to demonstrate using ggplot2 to construct the frames of the animation and ImageMagick to combine the frames into a gif of a simple monte carlo simulation.

Generate the Data

First, I’m going to use base R’s random sampling functions for the Poisson and the Negative Binomial to generate samples given the presumed parameters. The numbers are then added together to show a very basic monte carlo simulation. In addition, a “slice” of the data is taken that I’m going to use later to break down each step of the simulation.

library(ggplot2)
library(trstyles)
library(dplyr)
library(tidyr)
set.seed(82)
n <- 10000
mcHist <- data_frame(Poisson = rpois(n, 3), 
                  NegBinom = rnbinom(n, 5, .5)) %>%
  mutate(Simulation = Poisson + NegBinom) %>%
  gather(Distribution, Value) %>%
  mutate(Distribution = sub("NegBinom", "Negative Binomial", Distribution))

mcSample <- mcHist %>%
  group_by(Distribution) %>%
  slice(1:200) %>%
  gather(Distribution, Value) %>%
  group_by(Distribution) %>%
  mutate(rowNum = row_number(Distribution))

lapply(split(mcHist[['Value']], mcHist[['Distribution']]), summary)

$`Negative Binomial`
   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
  0.000   3.000   4.000   5.017   7.000  25.000 

$Poisson
   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
  0.000   2.000   3.000   2.991   4.000  12.000 

$Simulation
   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
  0.000   5.000   8.000   8.008  10.000  29.000 

Histogram of Expected Results

The background image that I want to show is what is the theoretical model that we are moving towards. I created a large sample of 10,000 so that random number generators will give a close approximation of the population (the presumed distributions). I chose discrete distributions above so that it will be easy to plot histograms without having to worry about the bin widths. With a little tweaking using facet_grid and geom_text, I can lay out each distribution and annotate the calculation.

g <- ggplot(mcHist) +
  geom_histogram(aes(Value, ..density.., color = Distribution), 
                 binwidth = 1, alpha = .3, fill = "transparent") +
  scale_color_tr(guide = FALSE) +
  facet_grid(~Distribution) +
  theme_tr() + 
  coord_cartesian(ylim = c(0, .23)) +
  labs(x = "", y = "Frequency") +
  theme(panel.grid = element_blank(), 
        strip.text = element_text(size = 16, hjust  = 0.1),
        axis.text.x = element_blank()) +
  geom_text(x = rep(21, 3*n), y = rep(.1, 3*n), 
            label = rep(c("+", "=", ""), each = n), size = 24)
g

Create Frames for Animation

Now that I have my starting frame to show each individual sample, I am going to use geom_dotplot to plot over the histogram. To help track the simulation moving through time, the latest sample will be colored red. The for loop iterates over each row number, filters to the current state of the simulation, and updates what is to be plotted. Then the handy ggsave saves each frame for the animated gif.

for (i in 1:length(unique(mcSample$rowNum))) {
  dataUpdate <- mcSample %>%
    group_by(Distribution) %>%
    filter(rowNum %in% 1:i) %>%
    group_by(Distribution) %>%
    mutate(Last = rowNum == i)
  gUpdate <- g +
  geom_dotplot(data = dataUpdate,
               aes(Value, fill = Last), color = NA, 
               binwidth = 1, method = "histodot",
               dotsize = .6) +
    scale_fill_manual(guide = FALSE, values = c("black", "red")) 
  #gUpdate  
  ggsave(filename = paste0('frames/plot', sprintf("%03d",i) , '.jpg'),
         plot = gUpdate, device = 'jpeg')
}

Convert Using ImageMagick

All the heavy lifting is over now. I just need to use ImageMagick to process the frames and convert to a gif. You can use a call to the command line here, but my personal preference is to just switch to the command line. ImageMagick is a standalone utility software that you will need to install separately from R.

convert -delay 20 -loop 0 *.jpg ../mcsim_animation.gif

I now have an animation that I can use to explain my distribution assumptions and show how each sample updates the model. It’s pretty clear over time that the sampling will eventually converge to the theoretical model.

Systems Definition, Analysis, and Design

System Analysis and Design Tools

Cause-Effect Diagram (Fishbone)

Pareto Analysis

80% of the items represent 20% of the sales or 20% of the items represent 80% of the cost. This law is a rule of thumb.

Operation Process Chart

The operation process chart only has Operations and Inspections.

Flow Process Chart

The flow process chart forces a more detailed look at a system.

Affinity Diagram

organizes a large number of ideas into their natural relationships

Left Hand Right Hand Chart

Shows when each hand is busy and idle. It is sometimes called a simo chart.

Modeling Techniques

Queueing Models

$$Little's \: Law$$

$$L = \lambda W$$

\(M/M/c/K\quad Queue\)

Effective vs. Offered Load:

$$\lambda_{eff} = \lambda(1-\pi_m)$$

Waiting Time Law:

$$L = \sum_{n=0}^Mn\pi_n$$ $$L_q = \sum_{n=c+1}^{c-1}(n-c)\pi_n$$

Probability of n arrivals by time t:

$$P[N(t)=n]=\frac{(\lambda t)^ne^{-\lambda t}}{n!}$$

\(M/M/1/\infty\quad Queue\)

Probability of customers in system:

$$\pi_0=1-\rho$$ $$\pi_n=\rho^n(1-\rho)$$ $$L = \frac{\rho}{1-\rho}$$ $$L_q = L-\rho=\frac{\rho^2}{1-\rho}$$

\(M/G/1/\infty\quad Queue\)

Pollaczek-Khintchine Formula:

$$L = L_q+\rho=\frac{\rho^2+\lambda^2\sigma^2}{2(1-\rho)}+\rho$$

\(M/M/c/M\quad Queue\)

$$D = \sum_{n=0}^{c-1}\frac{\rho^n}{n!}+\frac{\rho^c}{c!}[\frac{1-(\rho/c)^{M-c+1}}{1-\rho/c}]$$ $$\pi_0=\frac{1}{D}$$

$$\pi_n= \begin{cases} \frac{\rho^n}{n!}\pi_0, \quad \text{n<c} \\ \frac{\rho^n}{c!c^{n-c}}\pi_0, \quad {n\geq c} \end{cases}$$

$$L_q=\pi_0\bigg(\frac{\rho^{c+1}}{(c-1)!(c-\rho)^2}\bigg) \bigg[1-\big(\frac{\rho}{c}\big)^{M-c}-(M-c)\big(\frac{\rho}{c}\big)^{M-c}\big(1-\frac{\rho}{c}\big)\bigg],\quad \rho\neq c$$

$$L_q=\pi_0\bigg(\frac{\rho^c (M-c)(M-c+1)}{2c!}\bigg),\quad \rho=c$$

$$L_q=\pi_0\bigg(\frac{\rho^{c+1}}{(c-1)!(c-\rho)^2}\bigg),\quad c=\infty$$

\(M/M/C/\infty \quad Queue\)

C = 1

$$P_0=1-\rho ,\quad L_q=\frac{\rho^2}{1-\rho}$$

C = 2

$$P_0=\frac{(1-\rho)}{(1=\rho}, \quad L_q = \frac{2\rho^3}{(1-\rho^2)}$$

C = 3

$$P_0 = \frac{2(1-\rho)}{2+4\rho+3\rho^2}, \quad \frac{9\rho^4}{2+2\rho-\rho^2-3\rho^3}$$

Model Verification

A model has been verified if a range of models produce similar results on the same situation

Model Validation

A model has been validated if a range of results produce similar results on the same situation

Bottleneck Analysis

Optimize the process that is the bottleneck, then re-evaulate the bottleneck and repeat.

Facilities Engineering and Planning

People/Equipment Requirements

$$M_j = \sum_{i=1}^{n} \frac{P_{ij}T_{ij}}{C_{ij}}$$ $$M_j = \textrm{number of machines/people} \\ P = \textrm{production rate} \\ T = \textrm{production time} \\ C = \textrm{production period} \\ n = \textrm{number of products}$$

Material Handling

Euclidian:

$$d = \sqrt{(x_2-x_1)^2+(y_2-y_1)^2}$$

To optimize material flow:

$$min\quad \sum_{i=1}^mw_i[(x-a_i)^2+(y-b_i)]^{\frac{1}{2}}$$ If there are 4 locations with equal weight, the optimal location is the facility within a triangle of the other facilities. If there is no such facility, the optimal location is at the intersection of two lines.

When the weighted costs are proportional to the square of the Euclidean distance, it is called the ‘gravity’ problem.

$$min\quad \sum_{i=1}^mw_i[(x-a_i)^2+(y-b_i)^2]$$

$$x = \frac{\sum_{i=1}^mw_ia_i}{\sum_{i=1}^mw_i}$$ $$y = \frac{\sum_{i=1}^mw_ib_i}{\sum_{i=1}^mw_i}$$

Manhattan:

$$|x_2-x_1| + |y_2-y_1|$$

To optimize flow:

$$min\quad \sum_{i=1}^m w_i(|x-a_1|+|y-b_i|)$$

The x value is the median of the location x-coordinates. The y value is the median of the location y-coordinates.

Chebyshev (simultaneous x and y movement)

$$max(|x_2-x_1|,|y_2-y_1|)$$

Relationship Chart

Supply Chain Logistics

Forecasting Methods

Moving Average

$$\hat{d}_t = \frac{\sum_{i=1}^{n}d_{t-i}}{n}$$

Exponentially Weighted Moving Average

$$\hat{d}_t = \alpha d_{t-1}+(1-\alpha)\hat{d}_{t-1},\quad 0 \leq \alpha( \textrm{smoothing constant})\leq1 \\ d_{t-1} \text{ = actual demand, } \hat{d}_{t-1} \text{ = forecasted demand}$$

Production Planning Methods

Systems to compute Master Production and Ordering Plan

Material Requirements Planning (MRP)

Manufacturing Resource Planning (MRPII)

Engineering Economics

$$\bigg(\frac{F}{P}\bigg)= (1+i)^N, \quad \bigg(\frac{P}{F}\bigg)= \frac{1}{(1+i)^N} \\ \bigg(\frac{F}{A}\bigg)= \frac{(1+i)^N-1}{i}, \quad \bigg(\frac{P}{A}\bigg)= \frac{(1+i)^N-1}{i(1+i)^N} \\ \bigg(\frac{A}{F}\bigg)= \frac{i}{(1+i)^N-1}, \quad \bigg(\frac{A}{P}\bigg)= \frac{i(1+i)^N}{(1+i)^N-1} \\ \bigg(\frac{P}{G}\bigg)=\frac{1}{i}\bigg[\frac{(1+i)^N-1}{i(1+i)^N}-\frac{N}{(1+i)^N} \bigg], \quad \bigg(\frac{A}{G}\bigg)=\frac{1}{i}-\frac{N}{(1+i)^N-1}$$

*Denominator is current value and Numerator is desired conversion

Depreciation

Modified Accelerated Cost Recovery System (MACRS) - See Tables

$$\text{Straight Line (SL) - } \frac{1}{n}$$

Production Scheduling Methods

Makespan

the time it takes from the start of the first job until the end of the last job

Scheduling Sequence

1. Earliest Due Date - order jobs by due date
2. Shortest Processing Time - order jobs by processing time
3. Critical Ratio - divide time remaining until due date by time left on the machine, order by smallest critical ratio

Johnson’s Optimal Rule for Two Machines

1. Find the shortest processsing times and arbitrarily break ties
2. If the shortest processing time is on Machine A, schedule immediately. If the shortest processing time is on Machine B, schedule it as late as possible.
3. Eliminate the last job scheduled on the list and repeat step 1-2.

Inventory Management and Control

Economic Order Quantity

$$Q^*=\sqrt{\frac{2C_pD}{h}R} \\ R = \frac{1}{1-\frac{D}{P}},\quad\textrm{R=1, when replenishment is instaneous} \\ D=\textrm{demand},P=\textrm{production rate},C_p=\textrm{cost per order},h=\textrm{holding cost}$$

Economic Manufacturing Quantity

Use the equation above with R not equal to 1.

With shortage costs

$$Q^* = \sqrt{\frac{2C_pD}{h}R\big(\frac{h+z}{z}\big)} \\ z = \textrm{shortage cost}$$

$$M^*=\sqrt{\frac{2C_pD(1-\frac{D}{P})h}{z(h+z)}} \\ M = \textrm{allowed shortage}$$

Carrying Cost

$$C_T=\frac{hQ}{2}\big(1-\frac{D}{P}\big)+CD+C_p\frac{D}{Q}$$

Probabilistic Inventory and Production Models

$$F_D(x=y^*)\ge\frac{p-c}{p+h} \\ F_D = \textrm{CDF} \\ x = \textrm{units on hand}, y^*=\textrm{optimal order quantity}, p = \textrm{loss of potential revenue},\\ h = \textrm{loss in value from holding}, c = \textrm{unit acquisition cost}$$

Distribution Methods

Transhipment:

The intermediary storage

Transportation Problem

$$min \quad \sum_{i=1}^m \sum_{j=1}^nx_{ij}c_{ij} \\ \sum_{j=1}^nx_{ij}=s_i, n = 1, 2, ..., m \\ \sum_{i=1}^mx_{ij}=d_j, m = 1, 2, ..., n$$

Storage and Warehousing Methods

1. Dedicated Storage
   • easy to retrieve items
   • Sum of maximum of each product
2. Random Storage
   • more efficient use of space
   • Maximum of the sums of all products

Transportation Modes

1. Variable Path
   • truck, vehicle anything that does not have one fixed path
   • versatility
2. Fixed Path
   • conveyor
   • tied to one path

Assignment Problem

Hungarian Procedure:

1. Subtract the minimum of the row from all elements in the row
2. Substract the minimum of the column from all elements in the columns
3. Try to make a valid assignment using the zero elements, if all assigments cannot be made proceed to next step
4. Cover all zeroes with the minimal number of lines
5. From each uncovered element subtract the minimum of the uncovered y, add y to each intersection element. Go to step 3.
6. Transfer the assignment plan to the original cost table.

Work Design

Controls

An administrative control are training, policies, or procedures.

An engineering control is a physical modification to mitigate hazards.

Noise Dose

Dose

$$D=100*\big(\frac{C_1}{T_1}+\frac{C_2}{T_2}+...+\frac{C_n}{T_n}\big)\le 100$$

Time Weighted Average

$$TWA=16.61log_{10}\big(\frac{D}{100}\big)+90$$

Exposure

Time Weighted Concentration

$$TWA=\frac{\sum_{i=1}^nC_iT_i}{\sum_{i=1}^nT_i}$$

Taylor Tool Life

$$VT^n=C \\ V = \textrm{speed surface feet per minute} \\ T = \textrm{tool life in minutes} \\ C,n = \textrm{constants that depend on material and tool}$$

Work Sampling

$$D = Z_{\alpha/2}\sqrt{\frac{p(-1-p)}{n}}, \quad Z_{\alpha/2}\sqrt{\frac{1-p}{pn}} \\ p = \textrm{proportion of observed time} \\ D = \textrm{absolute error} \\ R = \textrm{relative error} = \frac{D}{p} \\ n = \textrm{sample size}$$

Sample Size

$$E = \frac{z_{\frac{\alpha}{2}}\sigma}{\sqrt{n}}$$

$$n = \bigg( \frac{z_{\frac{\alpha}{2}}\sigma}{E} \bigg)^2$$

Critical Path Method

$$T = \sum_{(i,j)\in CP}d_{ij}$$

Standard Time

$$\textrm{Observed Time * Pace Rating * (1 + personal time allowance) * (1 + fatigue allowance)}$$

Recommended Weight Limit

Units are pounds and inches.

$$RWL = 51\cdot (\frac{10}{H})\cdot (1-.0075|V-30|)\cdot (.82+\frac{1.8}{D})\cdot (1-.0032A)\cdot FM \cdot CM \\ \textrm{H = horizontal location of the load forward of the midpoint of the ankles} \\ \textrm{V = vertical location of the load} \\ \textrm{D = Vertical travel distance between the origin and the destination} \\ \textrm{A=angle of asymmetry between hands and feet} \\ \textrm{FM = frequency multiplier (from table)} \\ \textrm{CM = coupling mulitiplier (from table)}$$

Learning Curve

$$y=kx^n, n=\frac{log_{e}\phi}{log_{e}(2)} \\ \phi=\textrm{learning ratio}=\frac{T(2N)}{T(N)}, \textrm{T(N) = time to produce Nth unit} \\ \textrm{y= time to produce xth unit, k = time to produce first unit, x = cumulative number of units produced}$$

Total Learning Time:

$$T=k\frac{[(x_2+\frac{1}{2})^{n+1}-(x_1+\frac{1}{2})^{n+1}]}{n+1}$$

Remission Line:

$$y=k+\frac{(k-s)(x-1)}{1-x_s}$$

Quality Control

Statistical Process Control

X & R-Chart

$$UCL = D_4\bar{R} \\ CL = \bar{R} \\ LCL = D_3\bar{R}$$

$$UCL = \bar{\bar{X}}+A_2\bar{R} \\ CL = \bar{\bar{X}} \\ LCL = \bar{\bar{X}}-A_2\bar{R}$$

X & S-Chart

$$UCL=B_4\bar{S} \\ CL = \bar{X} \\ LCL = B_3\bar{S}$$

$$UCL = \bar{\bar{X}} + A_3\bar{S} \\ CL = \bar{\bar{X}} \\ LCL = \bar{\bar{X}}-A_3\bar{S}$$

P-Chart

$$UCL = \bar{p}+3\sqrt{\frac{\bar{p}(1-\bar{p})}{n}} \\ CL = \bar{p} \\ LCL = \bar{p} - 3\sqrt{\frac{\bar{p}(1-\bar{p})}{n}}$$

C-Chart

$$UCL = \bar{c}+3\sqrt{\bar{c}} \\ CL = \bar{c} \\ LCL = \bar{c}-3\sqrt{\bar{c}}$$

Tests for Out of Control

1. A single point falls outside three sigma control limits
2. Two out of three successive points fall on the same side of and more than two sigma units from the center line
3. Four out of five successive points fall on the same side of and more than one sigma unit from the center line
4. Eight successive points fall on the same side of the center line

Control vs. Capability

In control if it is within natural variability

Is capable if it is entirely within specification

Process Capability

Actual Capability:

$$C_{pk}=min\bigg(\frac{\mu-LSL}{3\sigma},\frac{USL-\mu}{3\sigma}\bigg)$$

Potential Capability:

$$C_p = \frac{USL-LSL}{6\sigma}$$

Reliability Analysis

Series:

$$R = \prod_{i=1}^n P_i$$

Parallel:

$$R = 1-\prod_{i=1}^n (1-P_i) $$

Hazard Function

$$h(x)=\frac{f(x)}{R(x)} \\ f(x) \text{ = density function, } R(x) \text{ = survival function}$$

Exponential $$h(x)=\lambda$$

Weibull $$h(x)=\frac{\beta}{\alpha}\big(\frac{x}{\alpha}\big)^{\beta-1}$$

Mean Time to Failure

$$\frac{1}{\lambda}, \\ \lambda \text{ = constant failure rate}$$

Six Sigma

Statistics

Normal Distribution

z-score

$$z=\frac{x-\mu}{\sigma}$$

Confidence Interval

$$\bar{x}\pm\frac{z_{\alpha/2} \sigma}{\sqrt{n}}$$

Two-means comparison:

$$z_0=\frac{\bar{x}_1-\bar{x}_2}{\sqrt{\frac{\sigma_1^2}{n_1}+\frac{\sigma_2^2}{n_2}}}$$

student-t Distribution

t-score:

$$t=\frac{\bar{x}-\mu}{\frac{s}{\sqrt{n}}}$$

Confidence Interval

$$\bar{x}\pm\frac{t_{\alpha/2,n-1}s}{\sqrt{n}}$$

Two-means comparison:

$$t_0=\frac{\bar{x}_1-\bar{x}_2}{\sqrt{\frac{s_1^2}{n_1}+\frac{s_2^2}{n_2}}}$$

df for Two Sample t-test:

$$df=\frac{\big(\frac{s_1^2}{n_1}+\frac{s_2^2}{n_2}\big)^2}{\frac{(\frac{s_1^2}{n_1})^2}{n_1-1}+{\frac{(\frac{s_1^2}{n_1})^2}{n_1-1}}}$$ Paired t-test:

$$t_0 = \frac{\bar{d}-0}{\frac{s_d}{\sqrt{n}}}$$

Hypothesis Testing

Chi-Squared Goodness of Fit

$$\chi^2=\sum_{j=1}^k\frac{(O_j-E_j)^2}{E_j}$$

Linear Regression

$$SSR=\sum_{i=1}^n(\hat{y}_i-\bar{y})^2$$

$$SSE = \sum_{i=1}^n(y_i-\hat{y}_i)^2$$

$$SST = \sum_{i=1}^n(y_i-\bar{y})^2$$

$$R^2=\frac{SSR}{SST} = 1-\frac{SSE}{SST}$$

ANOVA

$$SSA+SSE=SST$$

One-Way

Given Treatment A:

$$SSA+SSE=SST$$

Two-Way

Given treatment factors A & B:

$$SST=SSA+SSB+SSAB+SSE$$

Bayesian Analysis

Bayes' Theorem

$$P(A|B)=\frac{P(B|A)P(A)}{P(B)}=\frac{P(B|A)P(A)}{P(B|A)P(A)+P(B|A^\prime)P(A^\prime)}$$

Distributions

\(\text{Factors for Control Charts}\)

\(\text{Normal Distribution}\)

\(t \text{ Distribution}\)

\(\chi^2 \text{ Distribution}\)

\(F(v_1, v_2) \text{ Distribution}\)

References

[[1]]
Krishnamoorthi K (2006). _A First Course in Quality Engineering:
Integrating Statistical and Management Methods of Quality_. Pearson
Prentice Hall. ISBN 9780131472013, <URL:
https://books.google.com/books?id=lPQJAQAAMAAJ>.

[[2]]
Kutner M, Nachtsheim C, Neter J, Li W (2004). _Applied Linear
Statistical Models with Student CD_. McGraw-Hill
Companies,Incorporated. ISBN 9780073108742, <URL:
https://books.google.com/books?id=0Qq-swEACAAJ>.

[[3]]
Sullivan W, Wicks E, Luxhoj J (2006). _Engineering Economy_, number v.
1 series Engineering Economy. Pearson/Prentice Hall. ISBN
9780131486492, <URL: https://books.google.com/books?id=6pcoAQAAMAAJ>.

[[4]]
Gross D, Shortle J, Thompson J, Harris C (2011). _Fundamentals of
Queueing Theory_, series Wiley Series in Probability and Statistics.
Wiley. ISBN 9781118211649, <URL:
https://books.google.com/books?id=K3lQGeCtAJgC>.

[[5]]
Winston W (2003). _Introduction to Probability Models_. Cengage
Learning. ISBN 9780534405786, <URL:
https://books.google.com/books?id=L9yURQAACAAJ>.

[[6]]
Niebel B, Freivalds A (2003). _Methods, Standards, and Work Design_,
series McGraw-Hill series in industrial engineering and management
science. McGraw-Hill. ISBN 9780072468243, <URL:
https://books.google.com/books?id=ApXSoagqrxcC>.

fitur on CRAN

Density Diagnostic Plot

library(fitur)

## Warning: replacing previous import 'vctrs::data_frame' by 'tibble::data_frame'
## when loading 'dplyr'

library(ggplot2)
library(trstyles)
set.seed(37)
x <- rgamma(10000, 5)
dists <- c('gamma', 'lnorm', 'weibull')
fits <- lapply(dists, fit_univariate, x = x)
theme_set(theme_tr())
plot_density(x, fits, nbins = 20)

QQ-Plot

The output is a ggplot object so you can add colors, styling, etc.

plot_pp(x, fits) +
  scale_color_tr()

PP-Plot

You can also zoom in on different areas.

plot_qq(x, fits) +
  scale_color_tr() +
  coord_cartesian(xlim = c(5,10))

Generating distribution values is very simple in R. The d, q, p, and r functions are all that you will need to fill in the table values. The table below is for the t distribution.

alpha <- c(.1, .05, .025, .01, .005)
v <- c(seq(1, 30, by = 1), Inf)
tTable <- sapply((1-alpha), function(x) qt(x, df = v))
colnames(tTable) <- alpha

I’m using the xtable package here to format my table. It has some handy options to parse math symbols and notations with its sanitize.text print options and allows more customization of table style than the kable function in knitr. I’m setting some of style options below.

options(xtable.type = 'html',
        xtable.caption.placement = "top",
        xtable.include.rownames = FALSE,
        xtable.html.table.attributes= list("border='2' cellpadding='15' cellpadding='5' rules ='all' width ='100%'"))

When rendering the table, you can use LaTeX notation within the data of the table and have it parsed into math notation.

library(xtable)

tTable <- data.frame("$v \\big\\backslash \\alpha$" = paste0("", v, ""),
                     tTable,
                     stringsAsFactors = FALSE,
                     check.names = FALSE)
tTable[[1]][tTable[[1]] == "Inf"] <- "$\\infty$" 
tTable <- xtable(tTable,
                      caption = "Table 3: Percentiles of the *t* Distribution",
                      align = rep("c", ncol(tTable)+1),
                      digits = 4)
print(tTable)

I also wanted to include a plot of the distribution and describe what the values are visually. ?mathplot provides a guide to writing math notation in expression to show math notation in plots. More information on how the math notation will look is available here.

library(ggplot2)

x <- seq(-3.5, 3.5, by = .001)
ggplot() +
  geom_ribbon(aes(x = seq(qnorm(.95), max(x), by = .001),
                  ymin = 0,
                  ymax = dnorm(seq(qnorm(.95), max(x), by = .001))),
              fill = 'gray') +
  geom_vline(xintercept = 0, color = "black") +
  geom_hline(yintercept = 0, color = "black") +
  stat_function(data = data.frame(x=x),aes(x = x),  
                fun = dnorm, 
                size = 1) +
  geom_segment(aes(x = qnorm(.95),
                   y = 0,
                   xend = qnorm(.95),
                   yend = dnorm(qnorm(.95))
  ),
  
  color = 'black') +
  theme_void() +
  theme(plot.margin = unit(c(.1,.1,.1,.1), "cm")) +
  annotate(geom = 'text',
           x = c(qnorm(.95)),
           y = c(-.04),
           label = c(expression(t[paste(alpha,',',v)])),
           size = 4,
           parse = TRUE) +
  coord_cartesian(ylim = c(-.06, dnorm(qnorm(.5))))

Below, is the code for the rest of the tables. I’ve also placed a printable version here.

\(\text{Normal Distribution}\)

x <- seq(-3.5, 3.5, by = .001)
ggplot() +
  geom_ribbon(aes(x = seq(min(x), qnorm(.95), by = .001),
                  ymin = 0,
                  ymax = dnorm(seq(min(x), qnorm(.95), by = .001))),
              fill = 'gray') +
  geom_vline(xintercept = 0, color = "black") +
  geom_hline(yintercept = 0, color = "black") +
  stat_function(data = data.frame(x=x),aes(x = x),  
                fun = dnorm, 
                size = 1) +
  geom_segment(aes(x = qnorm(.95),
                   y = 0,
                   xend = qnorm(.95),
                   yend = dnorm(qnorm(.95))
  ),
  
  color = 'black') +
  theme_void() +
  theme(plot.margin = unit(c(.1,.1,.1,.1), "cm")) +
  annotate(geom = 'text',
           x = c(qnorm(.95)),
           y = c(-.04),
           label = c(expression(z[alpha])),
           size = 4,
           parse = TRUE) +
  coord_cartesian(ylim = c(-.06, dnorm(qnorm(.5))))

normalTable <- matrix(round(pnorm(seq(0, 3.49, by = .01)), 4), 
                      ncol = 10,
                      byrow = TRUE)
colnames(normalTable) <- seq(0, .09, by = .01)
z <- sprintf("%01.1f", seq(0, 3.4, by = .1))
normalTable <- data.frame("$z$" = paste0("", z, ""),
                          normalTable,
                          stringsAsFactors = FALSE)
colnames(normalTable) <- c("z", seq(0, .09, by = .01))
normalTable <- xtable(normalTable,
                      caption = "Table 2: Cumulative Probabilities of the Standard Normal Distribution, $X \\sim N(0,1)$",
                      align = rep("c", ncol(normalTable)+1),
                      digits = 4)
print(normalTable)