Baby name generator!

https___pbs.twimg.com_profile_images_1324348325_funny-baby-picture-angry-baby_400x400

Having recently become a dad, I thought I would share this code nugget with all of the parents to be out there!

This is a baby name generator Shiny app that uses the wonderful Hadley Wickhams’ babynames package.

You can find the app here

#Load packages
library(shiny)
library(babynames)
###UI
ui<-fluidPage(

  #Application title
  titlePanel("Baby name generator"),

  #Sidebar layout
  sidebarLayout(
    sidebarPanel(

      #Slider to select the number of names to show
       sliderInput("number",
                   "Number of names:",
                   min = 1,
                   max = 50,
                   value = 30),

      #Slider to select the age range to draw names from
       sliderInput("year",
                   "Year:",
                   min = 1880,
                   max = 2017,
                   value = 2017,sep=""),

      #Select input for the popularity rating
       selectInput("popularity","Popularity:",c("High","Medium","Low"),selected="High"),

      #Select input for the gender
       selectInput("gender","Gender:",c("M","F"),selected="M")
    ),

    #Table output
    mainPanel(
       tableOutput("name")
    )
  )
)

####Server
server<-function(input, output) {

  output$name<-renderTable(colnames=F,{

    #Setting up the subsets for the inputs
    d<-subset(babynames,babynames[,1]==input$year & babynames[,2]==input$gender)

    d<-data.frame(d)

    #Cutting the popularity data and binning it
    d$cat<-cut(as.numeric(d[,5]), seq(0,0.001,length=4),right=FALSE,labels=c("Low","Medium","High"))
    d<-subset(d,d$cat==input$popularity)

    #Return a sample of names. Determined by the slider input in the ui
    sample(d$name,size=input$number)

  })

}

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

Image mapper in R shiny

Capture

I have created a simple image mapper in R Shiny so that you can click on an image and then get a heat map of the spatial distribution of the clicked points. Enjoy!

The heat map image will only appear once you have click some points and then saved them

You can find the app here


#Load packages
library(shiny)
library(shinyWidgets)
library(shinyjs)
library(png)
library(spatstat)
library(raster)

#Load image
ima<-readPNG("Image.PNG")

####UI
ui<-fluidPage(
  # Application title
  titlePanel("Image map"),

  #Adding a switch for switching between likes and dislikes
  switchInput("col",value=TRUE,onLabel = "Like",
              offLabel = "Dislike", onStatus = "success", offStatus = "danger"),

  #Adding buttons to reset or save the clicked points in to a data.frame
  actionButton("undo", "Reset"),
  useShinyjs(),
  actionButton("updateplot", "Save"),

  #Rendering the plots in shiny
  plotOutput("plot1", click = "plot_click",height=dim(ima)[1],width=dim(ima)[2]),
  plotOutput("plot2",height=dim(ima)[1],width=dim(ima)[2])
)

####Server
server=1)
      shinyjs::show("updateplot")
  }) 

  #Creating the logic to store points you have clicked on
  val<-reactiveValues(clickx = NULL, clicky = NULL,
                        clickx2 = NULL, clicky2 = NULL)

  #Observes the clicks dependent on whether you have selected
  #Like or Dislike
  observe({
    input$plot_click

    if(input$col==TRUE){
      isolate({
        val$clickx = c(val$clickx, input$plot_click$x)
        val$clicky = c(val$clicky, input$plot_click$y)
      })
    }
    else(isolate({
      val$clickx2 = c(val$clickx2, input$plot_click$x)
      val$clicky2 = c(val$clicky2, input$plot_click$y)
    })
    )

  })

  #Setting up the action for the reset up
  observeEvent(input$undo, {
    isolate({
      val$clickx = NULL
      val$clicky = NULL
      val$clickx2 = NULL
      val$clicky2 = NULL
    })
  })

  #First plot. This will be the plot you will click
  output$plot1<-renderPlot({
    plot(1,type="n",yaxt="n",xaxt="n",xlab="",ylab="")
    lim1)){
      newDF<-rbind(data.frame(x=val$clickx,y=val$clicky,cat="Like",sys.time=paste(Sys.time())),
                   data.frame(x=val$clickx2,y=val$clicky2,cat="Dislike",sys.time=paste(Sys.time())))
    }
    else(newDF<-rbind(data.frame(x=val$clickx,y=val$clicky,cat="Like",sys.time=paste(Sys.time()))))

    #Optional. This is to create unique idenitfiers, so you can isolate every unique session
    sam<-list()
    sam[[1]]<-1:30
    sam[[2]]<-letters
    sam[[3]]<-LETTERS
    sam[[4]]<-c("!", "$", "%", "&", "(", ")", "*")

    tmp<-mapply(sample,sam,c(10,10,10,10),TRUE)
    newDF$session_id<-paste(sample(tmp,10),collapse="")

    #Reading in any existing data and adding it to the current clicks
    existing<-read.csv("Heat_map_data.csv")
    comb<-rbind(existing,newDF)
    write.csv(comb,"Heat_map_data.csv",row.names=F)
  })

  observeEvent(input$updateplot, {
    output$plot2<-renderPlot({
      plot(1,type="n",yaxt="n",xaxt="n",xlab="",ylab="")
      lim<-par()
      rasterImage(ima, lim$usr[1], lim$usr[3], lim$usr[2], lim$usr[4])

      dd<-read.csv("Heat_map_data.csv")

      #Using spatstat to map the spatial distribution of points
      coord.like<-with(subset(dd,dd$cat=="Like"),ppp(x,y,c(0,3),c(0,3)))
      coord.dislike<-with(subset(dd,dd$cat=="Dislike"),ppp(x,y,c(0,3),c(0,3)))

      zl<-density(coord.like, 0.05)
      zd<-density(coord.dislike, 0.05)

      #Setting up the overlay colours
      l_palette<-colorRampPalette(c("transparent","green"))
      d_palette<-colorRampPalette(c("transparent","red"))
      l_opaque<-l_palette(5)
      d_opaque<-d_palette(5)

      l_trans<-paste(l_opaque,c("10",rep("80",4)),sep = "")
      l_trans_trans<-rep("transparent",5)
      d_trans<-paste(d_opaque,c("10",rep("80",4)),sep = "")
      d_trans_trans<-rep("transparent",5)

      #Plotting the Like and Dislike overlays
      plot(zl, add=T, col = if(nrow(subset(dd,dd$cat=="Like"))==0){l_trans_trans}else{l_trans})
      plot(zd, add=T, col = if(nrow(subset(dd,dd$cat=="Dislike"))==0){d_trans_trans}else{d_trans})

      #Adding the highest density points
      zr = raster(zl)
      points(xyFromCell(zr, which.max(zr)),pch=16,cex=2,
             col=ifelse(nrow(subset(dd,dd$cat=="Like"))==0,
                        "transparent","darkgreen"))

      zr2 = raster(zd)
      points(xyFromCell(zr2, which.max(zr2)),pch=16,cex=2,
             col=ifelse(nrow(subset(dd,dd$cat=="Dislike"))==0,
                        "transparent","darkred"))

    })
  })
}

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

Password protect(ish) your Shiny app

Ihate-Passwords-2

I have trawled through various blogs looking for ways in which to password protect my Shiny apps. As a self described ‘coding moron’, I have struggled with some of the more complicated suggestions. So I set out to find the simplest, cleanest solution to my password protection woes, and here it is:

Disclaimer: This is not designed to give you high level password protection. Anyone with advanced computer skills can easily circumnavigate this protection and view your app/data.

library(shiny)

ui <- fluidPage(

  # Application title
  titlePanel("My password protected Shiny App"),

  # Sidebar with user input elements
  sidebarLayout(
    sidebarPanel(
      passwordInput("pwIn", "Passcode")

    ),

    # Show a plot
    mainPanel(
      plotOutput("distPlot")
    )
  )
)

server <- function(input, output) {

  output$distPlot <- renderPlot({

    #This is essentially your password code snippet. The below graoh will not run
    #unless you type the password; test
    validate(
      need(input$pwIn=="test", "Please enter the passcode"
      ))

    #Generate data and draw plot
    x<-sample(1:10,10)
    y<-sample(1:10,10)
    plot(x,y)

  })
}

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

 

All about that base: some cool and useful functions for base plots and beyond

meghan_trainor_photos-770x470

You’re either in the ggplot gang or the base plot gang. Despite what I joke to people about, I like ggplot, I have just plide my trade in base plot. Along the way, I have found some pretty useful snippets of code that are handy for base and to a lesser extent ggplot. I will be updating this sporadically when I come across more useful functions.

##Text and sequence manipulation
#Round up nice. Round up a sequence to the nearest 10.
roundUpNice = function(x, nice=c(1:10)) {
  if(length(x) != 1) stop("'x' must be of length 1")
  10^floor(log10(x)) * nice[[which(x <= 10^floor(log10(x)) * nice)[[1]]]]
}

#Wrapping strings. For when you have lengthly text that you automatically want to spread across
#multiple lines. The width argument determines where to cut the string.
wrap_strings = function(vector_of_strings,width){sapply(vector_of_strings,FUN=function(x){paste(strwrap(x,width=width), collapse="\n")})}
#e.g. wrap_strings(mytxext,width=15)
#If you have one line of text and want to split it up, then use the \n argument
txt = "Hugh Jackman\nis my bae"

#Orientating the x-axis to a given angle (and not just those set via las). The srt number defines
#the angle. Remember to put xpd =TRUE, so you can plot outside of the plotting area.
text(x.range,1,
    srt = 50, adj= 1, xpd = TRUE,
    labels = names)

##Fine details
#Setting the transparency of colours. The second argument is the alpha level. 1 for non-transparent,
#0 for completely transparent
adjustcolor("blue",0.3)

#This changes the height between text thats on 2 lines
par(lheight=0.3)

#If all else fails and you want to make the graph in Excel,
#then this handy function should do the trick
write.excel <- function(x,row.names=FALSE,col.names=TRUE,...) {
 write.table(x,"clipboard",sep="\t",row.names=row.names,col.names=col.names,...)
}

 

Story time with papa Jamie

index

One cool R package I have been using lately, is ReporteRs. It essentially takes your plots etc and creates a PowerPoint of these. The quality of these are pretty good. This has been really useful for me, as I have been doing a lot of ‘data story boards’ for client presentations. Having a PowerPoint story board of all of my figures allows me to visualise what results I have, and what will be good for a client. If you’re a scientist writing a paper, this package will also come in handy as it will allow you to essentially create a PPT of your plots, diagnostics from these and even tables!

This is the final product here.

#Loading the package
require(ReporteRs)

#Create dummy variables
x=1:200
y=jitter(1:200,50)

#Setting up an lm model
m=lm(y~x)

#Set your working directory
setwd()

# Create a PowerPoint document. This is just an empty pptx doc at the moment
plots = pptx()

#Create your first slide. This will be a title slide
plots = addSlide(plots, "Section Header")
plots = addTitle(plots, "My storyline")

#Create a content slide
plots = addSlide(plots, "Title and Content")
plots = addTitle(plots, "Linear regression diagnostics")

#Wrap the plotting functions inside this wrapper.
#IMPORTANT. Anything you place in here such as functions,
#will not be avialable outside of it. So I suggest just placing
#the plotting stuff in here.
plotlm.diag= function(){
  #So we can have all of the plots on one page
  par(mfrow=c(2,2))

  #Plotting the diagnostics
  plot(m)
}

#This adds the plot to our empty plots Title and Content slide
plots = addPlot(plots, plotlm.diag,vector.graphic = T)
#Create a table output
plots = addSlide(plots, "Title and Content")
plots = addTitle(plots, "My lm output")

#The flextable output of the lm summary
plots = addFlexTable(plots, vanilla.table(data.frame("terms"=row.names(data.frame(summary(m)$coefficients)),
summary(m)$coefficients)))
#Create another content slide
plots = addSlide(plots, "Title and Content")
plots = addTitle(plots, "My plot")

plot1= function(){
  plot(x,y)
 }
plots = addPlot(plots, plot1,vector.graphic = T)

####Create PPT
writeDoc(plots, file = "mystoryline.pptx")

Creating pretty dials

1 d3w3uiLunDng-Cuj6rEO-A

R can do a lot of things really really well, but one thing it struggles to do (at least in base R anyway) is to create pretty visuals. I have recently been creating visuals for some clients and wrote some code to produce some pretty dials in R. I will start by building a simple dial, and then adding various bits to it.

1.Simple dial

 
###Create a sequence from your breaks
breaks.min=seq(from=0,to=100,by=2)

###Creating the dial shape
get.poly <- function(a,b,r1=0.5,r2=1.0) {
 th.start <- pi*(1-a/100)
 th.end <- pi*(1-b/100)
 th <- seq(th.start,th.end,length=100)
 x <- c(r1*cos(th),rev(r2*cos(th)))
 y <- c(r1*sin(th),rev(r2*sin(th)))
 return(data.frame(x,y))
}

###A nice big empty plotting area
par(mar=c(10,4,10,4))
plot(1,ylim=c(0,1),xlim=c(-1,1),type="n",axes=F,xlab="",ylab="")
###Dialling in the numbers
#Where you want the dial to finish
pos<-70

#The coloured section up to your position
p<-get.poly(breaks[1],pos,0.75) 
polygon(p,col="lightgreen",border=NA)

#From your position to the end of the dial
p<-get.poly(pos,breaks[11],0.75)
polygon(p,col="lightgrey",border=NA)

Ta da! Here we have the output for the most simple of simple dials

1 On-eNjk5ksLXrlm5Q6fHHQ

Locator arrows in R

location-pixabay-1200x800-100728584-large

When creating advanced visualisations in R, determining the coordinates of where to put your arrows or text can be a tricky thing. Luckily, there is an awesome function in R called ‘locator‘.

##Make a plot
plot(1:10,1:10)

##Place locations of two arrows
loc.arrow<-locator(4)

##Once this line is run, the console run line should be flashing.
#click on a start and stop point of the where the first arrow should go,
##then the start and stop point on the second arrow.
##The console run line should then stop flashing

##run the loc.arrow line
##in this case
loc.arrow
$x
[1] 2.828149 2.798691 5.332089 7.070118
$y
[1] 4.646730 8.367149 7.477484 4.201897

#Adding the arrows to the plot
with(loc.arrow, arrows(x0=x[seq(1,4,by=2)], x1=x[seq(2,4,by=2)],
y0=y[seq(1,4,by=2)], y1= y[seq(2,4,by=2)]))