Create a Shiny Application to Collect Subscribers

Recently, my interest in shiny is very strong. These two days, I try to build a shiny application to collect subscribers. Actually, it a very simple applications, but I spends a lot of time on UI design and submit action. Unfortunately, I failed to add submit action. According to my original imagine, after you input name and email address, click , then this application should return you a message to alert your submit action is successful.

emmm… In fact, I add this feature to this application, but it doesn’t work, I think maybe there are some conflicts between shiny and shinybulma. If that case, forget it, just use it! To make sure you make a successful submit, you can click the submit button more than one times, generally, two times are enough.

Subsribe: Painter’s Alert

Next, I will illustrate how to write this shiny application.

UI Design

shinybulma is a very beautiful shiny framework, which I have already used many times in shiny applications’ development.

First, load shiny and shinybulma packages:

app.R

1 2	library(shiny) library(shinybulma)

Then source a R script, which contains some functions that can exchange data between R and MySQL. I have already demonstrated how to do it in last tweets.

database.R

library(RMySQL)
library(tibble)
# Initialization
# con = dbConnect(RMySQL::MySQL(), dbname = 'email', username = 'root', password = '12345678', host = 'localhost', port = 3306)
# df = tribble(
#   ~name, ~email,
#   "czxa", "[email protected]"
# )
# df
# dbRemoveTable(con, "emaillist")
# # if error happends, excute `set persist local_infile = 1` in MySQL.
# dbWriteTable(con, "emaillist", df, append = TRUE, row.names = FALSE)
# # Close connection
# dbDisconnect(con)

options(mysql = list(
  "host" = "localhost",
  "port" = 3306,
  "user" = "root",
  "password" = "12345678"
))
databaseName <- "email"
table <- "emaillist"

saveData <- function(data) {
  # Connect to the database
  db <- dbConnect(MySQL(), dbname = databaseName, host = options()$mysql$host, 
                  port = options()$mysql$port, user = options()$mysql$user, 
                  password = options()$mysql$password)
  # Construct the update query by looping over the data fields
  query <- sprintf(
    "INSERT INTO %s (%s) VALUES ('%s')",
    table, 
    paste(names(data), collapse = ", "),
    paste(data, collapse = "', '")
  )
  # Submit the update query and disconnect
  dbGetQuery(db, query)
  dbDisconnect(db)
}

loadData <- function() {
  # Connect to the database
  db <- dbConnect(MySQL(), dbname = databaseName, host = options()$mysql$host, 
                  port = options()$mysql$port, user = options()$mysql$user, 
                  password = options()$mysql$password)
  # Construct the fetching query
  query <- sprintf("SELECT * FROM %s", table)
  # Submit the fetch query and disconnect
  data <- dbGetQuery(db, query)
  dbDisconnect(db)
  data
}

app.R

source("database.R")

ui <- bulmaPage(
    tags$head(tags$script(src = "message-handler.js")),
    bulmaHero(
        fullheight = T,
        color = "primary",
        bulmaHeroBody(
            bulmaContainer(
                bulmaTitle("Painter's Alert"),
                bulmaSubtitle("Get email alerts when my blog gets updated"),
                bulmaTileAncestor(
                    bulmaTileParent(
                        bulmaTileChild(
                            HTML('
<div class="control has-icons-left has-icons-right">
  <input id = "name" class="input is-medium" type="email" placeholder="What can I call you?" value>
  <span class="icon is-left">
    <i class="fa fa-user"></i>
  </span>
  <span class="icon is-right">
    <i class="fa fa-check"></i>
  </span>
</div>'),
                            br(),
                            HTML('
<div class="control has-icons-left has-icons-right">
  <input id = "email" class="input is-medium" type="email" placeholder="Please insert your email here:" value>
  <span class="icon is-left">
    <i class="fa fa-envelope"></i>
  </span>
  <span class="icon is-right">
    <i class="fa fa-check"></i>
  </span>
</div>'),
                            br(),
                            bulmaActionButton(inputId = "submit", label = "Submit", color = "success"),
                            color = "light"
                        )
                    )
                )
            )
        )
    )
)

message-handler.js is the file used to add the reminder function. But I don’t know why it doesn’t work… May be I will fix it in the near future.

message-handler.js

// This recieves messages of type "testmessage" from the server.
// See http://shiny.rstudio.com/gallery/server-to-client-custom-messages.html
// for details
Shiny.addCustomMessageHandler("testmessage",
  function(message) {
    alert(JSON.stringify(message));
  }
);

Server

app.R

server <- function(input, output, session) {
    observeEvent(input$submit, {
      session$sendCustomMessage(
        type = 'testmessage',
        message = 'Thank you for subscribing!')
    saveData(tibble(name = input$name, email = input$email))
  })
}

# Run the application 
shinyApp(ui = ui, server = server)

There is a bulmaActionButton defined in UI part. It defines a event, which means the action defined in observeEvent() will only respond after you click the submit button.

Write Email in R

This applications can only collect subscriber’s name and email address. It can’t send email automatically. A common way to do this is to write another program. But I don’t think it’s a good idea, since it may cause unnecessary interruptions to subcribers. So I will just write email handly, but that not means I will log in my email account and send emails to every subscribers one by one. This job can be done in a very efficient way.

blastula package provides a very simple way to send email in R:

# devtools::install_github('rich-iannone/blastula')
# brew install openssl
library(magrittr)
library(blastula)
# current time：
(current_date_time <- add_readable_time())

# Contents
email_object <- compose_email(
  body = "
  ## Hiya! Thank you for subscribing to my personal website.
  
I promise not to disturb you, write weekly and only relevant information about my blog's update.

<div align='center'><img src='https://images.unsplash.com/photo-1567538096601-b3177180fa5d?ixlib=rb-1.2.1&ixid=eyJhcHBfaWQiOjEyMDd9&auto=format&fit=crop&w=800&q=60' width = '500px'/></div>
      
  I hope you enjoy these posts. Feel free to message me with any questions, concerns or ideas; or just let me know you like what I'm up to!
  
  If you have changed your mind, you can just reply me a email to let me konw, then I will remove your email from my list.
  
  Peace out,

  {sender}",
  
  footer = "Brought to you by Zhenxing Cheng on {current_date_time}",
  
  sender = "Zhenxing Cheng"
)

# preview
email_object

# create a credential
blastula::create_smtp_creds_file(
  file = "~/.e_creds",
  user = "[email protected]",
  host = "smtp.sina.com",
  port = 465,
  use_ssl = TRUE
)

# send email
email_object %>% 
  smtp_send(
    from = "[email protected]",
    to = "[email protected]",
    subject = "Thank you for subscribing!",
    credentials = creds_file(file = "~/.e_creds")
  )