Jekyll2026-05-03T19:31:47+00:00https://www.ndled.us/feed.xmlNoah LedbetterPersonal website dedicated to bad ramblings, cool datasets, and weird projects.GitHub Actions for Your Legacy Environment2025-02-16T00:00:00+00:002025-02-16T00:00:00+00:00https://www.ndled.us/devops/2025/02/16/github-actions-for-your-legacy-environmentI started at a new company in 2023 and while it was a great opportunity to take several steps further in my career, it also was a step back in terms of automation. When I first started, there were two servers that ran everything. One server running airflow for orchestration and another, runner server, for executing jobs. These two servers were in the same datacenter and were pretty locked down. The initial design, or lack there of, ran under a single users account linked through Active Directory. This was not ideal as I couldn’t get access to the production environment and every single deployment had to go through a single person’s account.

From day one, I wanted to remove this obstruction and automate code deployments. I needed to be able to deploy changes without the owner. The owner is human. The owner gets sick. The owner doesn’t check their Teams messages sometimes. At my last org, we used GitHub actions. I tried to bring that to the IT team as a tool we could use and hit a roadblock. It wouldn’t let GH through to the servers in our on prem datacenter. I was aware of Jenkins and that it runs a pull model rather than a push and started the process of getting that approved. That process is long though and I needed to do something now.

My first attempted fix was really bad. We used airflow as a CICD manager. Really. It was bad. For existing projects, the dag would have its first node run a bash command ssh to the runner server, change directory to the target project, and git pull.

from airflow import DAG
from airflow.operators.bash import BashOperator
from datetime import datetime
default_args = {
    'owner': 'airflow',
    'start_date': datetime(2020, 2, 15),
}
with DAG(
    'ssh_git_pull_dag',
    default_args=default_args,
    schedule_interval=None,
    catchup=False,
) as dag:
    git_pull_task = BashOperator(
        task_id='git_pull_task',
        bash_command="""
            ssh your_server_alias << 'EOF'
                cd /path/to/your/project
                git pull origin main
            EOF
        """,
    )

This sucked. Firstly, it was a lot to set up. At the time of implementation I was managing over a hundred dags tied to twenty distinct repos. It was a pain to track where a repo would get pulled since I didn’t do it every DAG related to that project. It technically worked, but I don’t even think it saved time considering all the setup and maintenance it required. The only upside? I could fix problems without the account owner.

Enter: The actual solution. Jenkins was still in IT approval hell. Airflow was sort of kind of working as an option but still needed ongoing maintenance and no one but me was familiar with the dags. I then read about self hosted runnersSelf-hosted runners solved everything. They could run inside the data center, listen for GitHub triggers, and execute arbitrary code—without IT approval. Best of all, I could get started without IT approval. And IT probably wouldn’t even notice!

In tandem with this project, I had requested more “runner” servers to segregate our qa, uat, prod, and dev environments. To begin (without IT support) I co-opted the dev environment runner server as an infrastructure server. On dev, I created a different runner for each repo I wanted to automate. Ideally, I could make use of shared GitHub runner servers across all of our repos but that requires git hub enterprise admin credentials and I was still doing this on the down-low.

Each runner could be created by following this with each action runner named after the repo it was going to be tied to. I also made sure to setup each runner as a service using the link found in the docs. Once the runners were live, setting up the YAML workflows was easy. The workflow my team wanted was deploy on merge and the fastest way to get started is the relatively simple workflow of on successful merge to target branch, ssh to the target runner server and git pull.

name: deploy
on:
  pull_request:
    branches:
      - main
    types:
      - closed
jobs:
  deploy:
    if: github.event.pull_request.merged == true
    runs-on: self-hosted
    steps:
      - name: deploy via ssh
        run: |
          ssh  <user>@<ip>
            cd <project_dir>
            git pull

Note that there was some setup with this… Notably, this expects the target server to be a known host and for a suitable ssh key to be in ./ssh

But that was it! It worked and now my teams work isn’t delayed until “deployment Fridays” or worse, delayed for another week because one person was out of office. This obviously has a ton of room to improve pending buy in from the management team. Firstly, we should really only be using one runner shared by all of the repos. We can scale that up as needed but first need to get the GH admin team to enable shared runner groups Next, we should package our deployments in some way. I would love to move my team to using docker containers for everything but we are a ways off for that. In the interim, I have proposed cloning the repo from scratch into a new dir and then creating a symlink to keep the last few versions deployed.

name: deploy
on:
  push:
    branches:
      - main
jobs:
  deploy:
    runs-on: self-hosted
    steps:
      - name: deploy via ssh
        env:
          RELEASE_DIR: "/path/to/your/app/releases"
          TIMESTAMP: $  # or use `date +%Y%m%d%H%M%S` for timestamp
        run: |
          ssh -o <user>@<ip> << 'EOF'
            set -e
            mkdir -p $RELEASE_DIR/$TIMESTAMP
            git clone https://github.com/<your-repo>.git $RELEASE_DIR/$TIMESTAMP
            cd $RELEASE_DIR/$TIMESTAMP
            ln -sfn $RELEASE_DIR/$TIMESTAMP /path/to/your/app/current
            cd $RELEASE_DIR
            ls -1tr | head -n -5 | xargs -d '\n' rm -rf --
          EOF

Automating CI/CD in a locked-down legacy environment wasn’t easy, but here is what I learned:

1. Don’t Wait for IT Approval If You Don’t Have To.

  • Self-hosted GitHub runners let me bypass bureaucracy.

2. Start Small and Iterate.

  • Airflow was bad, but it got me to the next step.

3. Self-Hosted Runners Are a Great Workaround for Restricted Environments.

  • They let me automate deployments without opening firewall rules.

If you’re stuck in a similar situation, try this. It’s not perfect, but it’s so much better than waiting for a human bottleneck.

]]>Learning Flask and Docker for inspire.ndled.us2022-05-25T00:00:00+00:002022-05-25T00:00:00+00:00https://www.ndled.us/python/2022/05/25/learning-flask-and-dockerYou can find the code here. The webapp has been decommissioned

Three months ago my fiancee expressed an interest in learning some practical scripting in python. I had her brainstorm ideas for something simple she’d like to accomplish and she came up with the inspiration for this project. I will note that while yes, I did technically steal this idea from her, she had already stopped working on it and I thought it was cool so…

Her idea was simple - She loves animal crossing, and puts on island tour videos like this one while she putts around the house. She constantly gets design ideas from these videos and thought it would be cool to create a script that would grab a random image from the video so she could use it for inspiration.

While she did learn some scripting, she only got as far as downloading youtube videos with a script before going off on a tangent to extract audio only from her music playlists. Lame. I thought it was a great idea so I kept with it!

The original script looked a little something like this, minus the references to static/single because initially this was all a command line tool.

def download(playlist_url):
    ydl_opts = {
        'outtmpl': resolvepath(f"tmp/videos/{'%(title)s-%(id)s.%(ext)s'}"),
        'download_archive': resolvepath("tmp/download.txt"),
        'overwrites': False,
        'format':'135' # Fun fact, has to be string
    }
    with YoutubeDL(ydl_opts) as ydl:
        ydl.download([playlist_url])
 
def single_cut():
    for file in os.listdir(resolvepath("static/single")):
        video_path = resolvepath(f"static/single/{file}")
    image_name = os.path.basename(video_path)
    cap = cv2.VideoCapture(video_path)
    length = int(cap.get(cv2.CAP_PROP_FRAME_COUNT))
    randomframe = random.randint(0,length)
    while(cap.isOpened()):
        frameId = int(cap.get(1))
        print(frameId)
        ret, frame = cap.read()
        if (ret != True):
            break
        if (frameId == randomframe):
            cv2.imwrite(resolvepath(f"static/single/{image_name}.jpg"), frame)
            image_path = f"static/single/{image_name}.jpg"
            print("wrote")
            cap.release()
            return image_path
    cap.release()

This worked fine, but I thought I could take this opportunity to learn flask and build a web app! The first iteration of the webapp even worked okay… As long as you didn’t refresh the page or have someone else attempt to process a video while your process was still on going. See, everything lived in the http request cycle which meant LONG load times for the result webpage.

def new():
    if request.method == 'POST':
        if request.form.get("submit"):
            form_data = request.form
            url = form_data['new_video']
            remove_old(dir = "static/new")
            down.single_download(url, path = "static/new")
            cap.new_cut(path = "static/new")
            image = random_image(img_dir = "./static/new")
            return render_template('new.html', image = image)
        elif request.form["random_image"]:
            image = random_image(img_dir = "./static/new")
            return render_template('new.html', image = image)
    else:
        return render_template('new.html')

Okay, we have a webapp that will do its thing, but I really need to offload that into something that lives outside of the actual serving of the webpage cycle. Enter Redis and Celery.

Redis does a lot of things, but really all I’m using it for is as a message broker. Celery is the workforce that runs the processing outside of the webserve cycle. Since I was already learning Flask and I needed to run Redis and Celery locally, I decided that I definitely wasn’t learning enough and needed to add learning Docker to my project. This has widely been considered a mistake and much suffering ensued.

But! I eventually got a system that would work for me. In dealing with all the fun added bits, the original project was shaved down from its scripted form. Minimum viable project and all that. Now I had a working prototype and multiple people could even use it at the same time! In my hubris I was not finished.

Okay so Digital Ocean fucking rules but I’m still going to complain about it anyways. I’m a pretty risk adverse person in both my personal and professional life. There is no fucking way to limit my financial risk with any cloud provider I know of. I just want a fucking toggle that will shut off AND KILL (I don’t care) my personal projects if I go over a billing threshhold. That threshold can be high! I’m cool with a max bill of like, five hundred dollars which would make me feel like a dumbass if I ever hit, but I don’t care! I just need some ability to limit my ability to fuck myself over. Anyways, Digital Ocean, like every other cloud provider I know of, doesn’t let you do that. Their documentation and tutorials are bomb though, so I can’t be too mad. It was surprisingly easy to integrate with Digital Ocean and I had a fully deployed flask app with about an hour’s worth of work. I even brought in ANOTHER Docker container for nginx to handle serving static content. The beautiful http site was up and running and by god it worked. I felt powerful.

Getting an ssl cert for https was a little more painful. If you’re unaware, The Electronic Frontier Foundation tries to make this easy for dumb people like me. They provide a neat package called certbot that is designed to make it easy as two enters, an email address, and a lonely y to grant a cert and configure nginx with it… Bummer I had Dockerized nginx on alpine linux, so certbot needed to be a little more manual. After spinning up the containers, I ran certbot with

 certbot certonly --webroot --webroot-path /var/www/certbot/

Next I needed to let nginx know about the cert, so I moved a new config file over

docker cp nginx/nginx.conf youtube_screen_grab_nginx_1:/etc/nginx/conf.d

With the config file looking like:

upstream youtube_screen_grab {
    server web:5000;
}
 
 
server {
    listen 80;
    listen [::]:80;
 
    server_name inspire.ndled.us www.inspire.ndled.us;
    server_tokens off;
 
    location /.well-known/acme-challenge/ {
        root /var/www/certbot;
    }
 
    location / {
        return 301 https://inspire.ndled.us$request_uri;
    }
}
 
server {
    listen 443 default_server ssl http2;
    listen [::]:443 ssl http2;
 
    server_name inspire.ndled.us;
 
    ssl_certificate /etc/nginx/ssl/live/inspire.ndled.us/fullchain.pem;
    ssl_certificate_key /etc/nginx/ssl/live/inspire.ndled.us/privkey.pem;
   
    location / {
        proxy_pass http://youtube_screen_grab;
        proxy_set_header X-Forwarded-For $proxy_add_x_forwarded_for;
        proxy_set_header Host $host;
        proxy_redirect off;
    }
}

And it’s up and running! This was a really neat process that walked me through my first time deploying something I wanted up in the cloud. Digital Ocean makes it very easy to get started and I’m thrilled with all the Flask and Docker I’ve learned while going through this.

This work would not be possible without the following blog posts and tutorials:

Official Flask Tutorial Dockerizing Celery and Flask Best Docker Tutorial I’ve found

Until next time,

Noah

]]>Hemimethylation Patterns in Breast Cancer Cell Lines2021-12-30T00:00:00+00:002021-12-30T00:00:00+00:00https://www.ndled.us/information/2021/12/30/epigenetics]]>New Job, Who This?2021-11-07T00:00:00+00:002021-11-07T00:00:00+00:00https://www.ndled.us/information/2021/11/07/new-jobI finally got a job! It took somewhere in the neighborhood of 4 months, 75 applications, 10 phone screenings, 20-something follow up rounds - and then, all in one day, I received three offers. I accepted a position I never even technically applied for at Alegion as a Customer Success Engineer, but more about that later. Switching careers happened very differently than I thought it would. I’m not really sure what I expected, but I certainly didn’t know how to look for a job. In education, I was competitive because of my license, my years of experience at a Title I project based learning school, and my academic background from UTeach. Every job I ever applied for as a teacher, I got. I never had to go through multiple rounds of interviews or experience rejection after investing tens of hours into a company. It sucked, let me tell you.

I also learned that I was terrible at interviewing for these tech jobs. I didn’t know what the interviewers were looking for, and I also didn’t know what I was looking for. Over the course of several months, I got a lot better at interviewing. I understood what it was that the interviewer was expecting to see, not just with the in person interviews, but also the take home data analyst assignments. I got a lot of those and I’m still mad about the ones that don’t give feedback after all that work! I just got shit-loads of practice. I interviewed with one financial tech company for 8 different rounds before eventually being given the rejection. That rejection was rough. I put in so much effort, and I got so far that it was demoralizing to see it break down all at once. Don’t get me wrong, I learned more from the interview process with that company than any other single thing I did during this transition period, but a rejection is a rejection. These rejections did something tricky to my brain state. I had a runway. I had saved enough money that I didn’t need to worry about a thing or change my lifestyle at all until December… That wasn’t how it felt. I started looking at jobs in May of 2021 and by the 50th rejection somewhere in July I started to freak the hell out. What if I was making a mistake? Should I really have left teaching? I am maybe secretly just a failure who has never done anything cool in my life and why would anyone hire me? Of course they are sending another rejection letter, they see you for the fraud you are!

But not everyone rejected me. When I was at my absolute lowest, I had been interviewing for four months and I just wasn’t making progress.then all of a sudden, I got my first offer letter from a green energy company offering me an internship while I finished out the year in my graduate program. A few literal hours later, I got an offer from Alegion, the 2nd company I ever interviewed with, for a role that I never applied for. Within 12 hours of that, I recieved yet another offer for a data analyst position. In the end, I accepted the offer with Alegion and couldn’t be happier.

As of September 22nd, 2021 I am the new Customer Success Engineer, and I’m not sure Alegion is 100% sure what I do yet. So far, I have been building structures. Before I arrived, Alegion didn’t have a standardized workflow for my department. We didn’t use version control, we didn’t document our processes and that made onboarding extremely challenging. I mean, it makes sense. When you are small all this information lies in individuals’ heads, and it’s all changing so fast that it might not be productive to take the time to write it all down. Now Alegion has reached more than 100 employees, and with this growth comes a strong need to document processes and to hold others accountable to those processes. I primarily get to work in python, and I am just loving it. Anytime I want to do something to improve the process, like developing a module that can be imported into each of our scripts, I can just do it. It is such a great place to learn and grow. The company culture of growth reminds me so much of what teaching is supposedly like. When you are student teaching and going through your first round of interviews, every school tells you that they are growth focused. They have such great mentor programs, and they are personally and individually invested in your success. I never found that to be true in education, but it feels true in the startup world, at least at Alegion. Maybe it’s just the new industry glasses, but I can’t imagine going back. I always want to learn like this.

Moving forward, I am going to continue to learn and push myself. My long term goal is still data science, and while it does feel like I am much closer than I was a year ago, there is still so far to go. At work, my new pet project is learning the BI tool Sisense, and in my personal time I am building a machine learning model for housing prices and how their proximity to drinkable water sources affect their price over time. I’m finally taking a course online over Data Structures and Algorithms. There is so much that I wish I learned in my undergraduate program or even my graduate program, and while both of them have taught me a lot, wow it is weird to take online versions of classes that my CS friends take for granted. It is nice that so much stuff exists out there for learning more CS topics, it makes the growth focus real easy in this stage of my knowledge.

Until next time,

Noah Ledbetter, Engineer

]]>Computer Vision Application2021-08-06T00:00:00+00:002021-08-06T00:00:00+00:00https://www.ndled.us/stats/2021/08/06/CV-OWLYou can find the code here on github.

This last month I started interviewing with the computer vision company Alegion and felt a little out of my depth. My experience with computer vision is next to nil, only really being exposed to it in a Udemy course that walked me through classifying images as either containing cats or dogs. I ended with some code that does an okay job but I didn’t really understand how I could translate that to video data.

So I went looking for other resources to learn more. I started with Analyics Vidhya and it was a perfect stepping stone and introduction to the topic. The tutorial covered reading (small) video files, extracting the frames, using the pretrained VGG16 model, inputting our data into the pretrained model, and creating predictions for a separate video file.

At this point I focused in on what I wanted to do with computer vision. My brother and I had been following Overwatch League for the last few years and had recently started getting together and watching the games. A constant source of annoyance for us has been how terrible the casters are at filling time. (This was especially insulting because the Starcraft casters were soooo much better.) I figured, what the hell, let’s try to apply computer vision to this problem. Let’s skip the casters filling time and any down time between matches.

I followed Vidhya’s tutorial pretty closely and wanted to move on to the next logical stage of my project where I would write out a video file. I got a little stuck here not realizing that I needed a different package other than cv2 to write audio, but after some false starts I found moviepy. Moviepy seemed like the perfect tool that wasn’t going to get as complicated as ffmpeg while still being able to do the tasks that I was looking for. The library home page included a gallery of example scripts and I found this example which was exactly what I needed. I followed along with their example and then moved to write my own. I ended up with a video that cut out about 20 minutes of video. I was pleased with my results but there were still some serious issues and misclassifications.

Above is a short video of the intro. Why did it keep all that? Why does it randomly skip, still to the casters talking? Overall, I was pleased I made something with computer vision, but it wasn’t very good. I went back to the drawing board and decided to drop the pretrained VGG16 model for a self-built model following a default approach set out in the Udemy course linked above. The model improves pretty drastically. In the video below, I show a clip where it is working pretty well, but we are skipping some of the start of gameplay chunks (and the end of some gameplay chunks.)

So, I added a window of 30 seconds around each clip. My next goal was to improve the amount of time it took to make predictions. My current code was based on the Analytics Vidhya example which used 5 minute clips. All told, that ended up with 300 frames held in memory while my average clip length is somewhere around 2 hours with something like 7000 frames which is back breakingly slow. I knew I could do something with a datagenerator and flow_from_directory, but I didn’t have any concrete examples to walk through.

I followed the documentation but ended up tripping over myself in a couple of different places. Firstly, I couldn’t get my generator to find any pictures because I didn’t read enough of the documentation to know that the image_generator.flow_from_directory still expects the images to be in a subdirectory even when they have no assigned class. It was an easy enough fix once I figured it out, but all of a sudden I was getting garbage predictions that didn’t make any sense. I kept comparing it to my prior memory intensive method and could understand what was happening. After some hair pulling and a lot of wasted backtracking I ran test_generator.filenames And uh-oh, I saw the problem and also duh! Of course it reads them in the order 0, 1, 10,100,1000,2,20… I needed to pad my numbers. I followed a stack exchange article to fix that problem and updated the code that cut up the frames accordingly so I wouldn’t have to do it again.

Success! My output video had maintained it’s quality and now ran much faster. In the above clip you can really see that 30 sec window before and after gameplay. The two major speedbumps are the training of the model, something I am only having to do each time since I keep adding to the training and validation data, and writing out the final video. I think I can get faster at writing out the final video using a callout to the commandline implementation of ffmpeg, but I have set that aside for the time being.

Instead, my next steps for this project are to

1) Make a callout to youtube.dl for the video file I want to predict so I can keep it all in this one notebook

2) Continue to add more training data - all of this data has been from the week 15 regular season. There could very well be different indicators of “not gameplay” in earlier weeks or years of the league.

3) Add in some sort of transition between cuts. As it stands right now, all of the cuts are hard and don’t look the best. I looked around and it seems that moviepy should be able to do it, but my one attempt thus far didn’t knit together all the way. This is probably my top priority even though it’s number three on the list.

4) I need to add weights to the data. Game play tends to happen a little less than twice as often, so the model should weigh correct predictions of not gameplay higher.

5) I probably should play around with both my smoothing function and my window of time on either side of a clip to keep. Just aesthetically, I bet I can make the clips feel smoother with more time on those values.

]]>Reconstructing Data2021-07-23T00:00:00+00:002021-07-23T00:00:00+00:00https://www.ndled.us/stats/2021/07/23/Reconstructing-DataLow rank approximation singular value decomposition for image compression

import numpy as np
import matplotlib.pyplot as plt
import matplotlib.image as mpimg
import scipy.linalg as la

def LowRankApprox(A,k): #Uses linalg svd to return an approximation to A of rank k

    # First, retrieve the SVD decomposition of A
    U, Sigma, Vadj = la.svd(A,full_matrices=False)

    # Take the vector of singular values, copy it, and kill all but the first k entries of the copy

    Sigma_cutoff = Sigma
    for i in range(len(Sigma)-k):
        Sigma_cutoff[k+i] = 0 #(Sigma_k in the notes)

    # Compute a new matrix using the cut-off singular values, and return it as value
    return np.dot(U*Sigma,Vadj) #This A_k = U times Sigma_k times V^* in our notes

def sz(k):
    return 1030*k+k+816*k

Image to Approximate

M = mpimg.imread('data.jpg') #Reads an RGB image, which is made out of 3 MxN matrices
picplot = plt.imshow(M)
M.shape

(1030, 816, 3)

png

Gray scale, so we don’t have to think about the RGB values

Mgs = np.mean(M, axis=2) #Create a grayscale image by averaging the colors of the 3 matrices
Mgs.shape
1030*816 #Original size of the grayscaled file

840480

picplot = plt.imshow(Mgs, cmap = 'gray')

png

VERY low rank approximation

rank = 1 # Set the rank of your approximation
B = LowRankApprox(Mgs,rank) # Best rank k approximation to the grayscale image
picshow = plt.imshow(B,cmap ='gray') #Plot the image
sz(1)

1847

png

Can’t see much of what’s going on. Can maybe make out a face, image size is very small

rank = 3
B = LowRankApprox(Mgs,rank)
picshow = plt.imshow(B,cmap ='gray')
sz(3)

5541

png

Better, can definetly see a face

rank = 15
B = LowRankApprox(Mgs,rank)
picshow = plt.imshow(B,cmap ='gray')
sz(15)

27705

png

Looks like data, even if blurry. Size is still heavily compressed

rank = 25
B = LowRankApprox(Mgs,rank)
picshow = plt.imshow(B,cmap ='gray')
sz(25)

46175

png

rank = 80
B = LowRankApprox(Mgs,rank)
picshow = plt.imshow(B,cmap ='gray')
sz(80)

147760

png

Can’t determine the difference between these two images. Maybe slight bluring at the line formed on his uniform. We are about 1/8th the size of the original image.

picshow = plt.imshow(Mgs,cmap ='gray') # Original image

png

Want to read more about this from other students? http://www.math.utah.edu/~gustafso/s2017/2270/projects-2016/kuhnConnor/kuhnConnor-svd-vs-dct-image-compression.pdf

]]>Austin Bikes2021-07-04T00:00:00+00:002021-07-04T00:00:00+00:00https://www.ndled.us/stats/2021/07/04/Austin-Bikes Austin Bike Data Exploration

Data set and description can be found here

Github page with cleaned up data and presentation here

Libraries I might use

library(ISLR)
library(tidyverse)
library(randomForest)
library(gbm)
library(MASS)
library(lubridate)
library(zoo)
library(GGally)
library(e1071) #SVM and NB library

Loading in the Data

bikedata = read.csv("Austin_MetroBike_Trips.csv")
weatherdata = read.csv("austindaily.csv")
bikedata
weatherdata

Data Cleaning

Weather Data

weatherclean = filter(weatherdata, year(X1938.06.01)>2012)
weatherclean = weatherclean[,c(1,2)]
colnames(weatherclean) <- c("Date","AvgTemp")
weatherclean$Date = as.Date(strptime(weatherclean$Date, format = '%Y-%m-%d'))
summary(weatherclean)
      Date               AvgTemp
 Min.   :2013-01-01   Min.   :-9.20
 1st Qu.:2015-02-12   1st Qu.:15.20
 Median :2017-03-26   Median :22.00
 Mean   :2017-03-26   Mean   :20.86
 3rd Qu.:2019-05-07   3rd Qu.:27.50
 Max.   :2021-06-20   Max.   :34.00
                      NA's   :88

But we can see we have 80 dates with missing temperature values. I would like to impute an average around it, but is that a sound strategy?

set.seed(123)
weathercleannn=na.omit(weatherclean)
fakeweather = weathercleannn
nas = sample (1:nrow(weathercleannn), nrow(weathercleannn)*0.02934703) # The same rate of missing values as in our original data set
fakeweather$AvgTemp[nas] <- NA
fakeweather$AvgTemp = (na.locf(fakeweather$AvgTemp) + rev(na.locf(rev(fakeweather$AvgTemp))))/2 # Fills in missing values with the average of the weather values on either side
mean((weathercleannn$AvgTemp[nas]-fakeweather$AvgTemp[nas])^2)
[1] 5.109943

Great! We are in a reasonable range of the true temperature and can apply this method to our dataset.

weatherclean$AvgTemp = (na.locf(weatherclean$AvgTemp) + rev(na.locf(rev(weatherclean$AvgTemp))))/2
weatherclean

Bike data

bikeclean = bikedata[,c(2,4,5,7,9,10)]
bikeclean[bikeclean==""] <- NA
bikeclean$Checkout.Time=hms(bikeclean$Checkout.Time)
bikeclean$Checkout.Date = as.Date(bikeclean$Checkout.Date,format='%m/%d/%Y')
summary((bikeclean))
 Membership.Type    Checkout.Date        Checkout.Time                       Checkout.Kiosk     Return.Kiosk       Trip.Duration.Minutes
 Length:1342066     Min.   :2013-12-21   Min.   :0S                          Length:1342066     Length:1342066     Min.   :    0.00
 Class :character   1st Qu.:2015-12-11   1st Qu.:12H 3M 46S                  Class :character   Class :character   1st Qu.:    6.00
 Mode  :character   Median :2017-09-21   Median :15H 12M 0S                  Mode  :character   Mode  :character   Median :   13.00
                    Mean   :2017-06-08   Mean   :14H 46M 47.7450237171652S                                         Mean   :   30.59
                    3rd Qu.:2018-08-27   3rd Qu.:18H 12M 0S                                                        3rd Qu.:   28.00
                    Max.   :2021-02-28   Max.   :23H 59M 56S                                                       Max.   :34238.00

Checkout Kiosk

sort(unique(bikeclean$Checkout.Kiosk))
  [1] "10th & Red River"                                                 "10th/Red River"                                                   "11th & Salina"
  [4] "11th & Salina "                                                   "11th & San Jacinto"                                               "11th/Congress @ The Texas Capitol"
  [7] "11th/Salina "                                                     "11th/San Jacinto"                                                 "12th/San Jacinto @ State Capitol Visitors Garage"
 [10] "13th & San Antonio"                                               "13th/San Antonio"                                                 "16th/San Antonio"
 [13] "17th & Guadalupe"                                                 "17th/Guadalupe"                                                   "21st & Speedway @PCL"
 [16] "21st & University"                                                "21st/Guadalupe"                                                   "21st/Speedway @ PCL"
 [19] "21st/University"                                                  "22nd & Pearl"                                                     "22nd/Pearl"
 [22] "23rd & Rio Grande"                                                "23rd & San Jacinto @ DKR Stadium"                                 "23rd/Rio Grande"
 [25] "23rd/San Jacinto @ DKR Stadium"                                   "26th/Nueces"                                                      "28th/Rio Grande"
 [28] "2nd & Congress"                                                   "2nd/Congress"                                                     "2nd/Lavaca @ City Hall"
 [31] "3rd & West"                                                       "3rd/Nueces"                                                       "3rd/Trinity @ The Convention Center"
 [34] "3rd/West"                                                         "4th & Congress"                                                   "4th/Congress"
 [37] "4th/Guadalupe @ Republic Square"                                  "4th/Neches @ MetroRail Downtown"                                  "4th/Sabine"
 [40] "5th & Bowie"                                                      "5th & Campbell"                                                   "5th & San Marcos"
 [43] "5th/Bowie"                                                        "5th/Campbell"                                                     "5th/Guadalupe @ Republic Square"
 [46] "6th & Chalmers"                                                   "6th & Chalmers "                                                  "6th & Congress"
 [49] "6th & Navasota St."                                               "6th/Brazos"                                                       "6th/Chalmers "
 [52] "6th/Congress"                                                     "6th/Lavaca"                                                       "6th/Trinity"
 [55] "6th/West"                                                         "8th & Congress"                                                   "8th & Guadalupe"
 [58] "8th & Lavaca"                                                     "8th/Congress"                                                     "8th/Lavaca"
 [61] "8th/Red River"                                                    "8th/San Jacinto"                                                  "9th/Henderson"
 [64] "ACC - Rio Grande & 12th"                                          "ACC - West & 12th"                                                "ACC - West & 12th Street"
 [67] "Barton Springs & Riverside"                                       "Barton Springs @ Kinney Ave"                                      "Barton Springs Pool"
 [70] "Barton Springs/Bouldin @ Palmer Auditorium"                       "Barton Springs/Kinney"                                            "Boardwalk West"
 [73] "Brazos & 6th"                                                     "Bullock Museum @ Congress & MLK"                                  "Capital Metro HQ - East 5th at Broadway"
 [76] "Capitol Station / Congress & 11th"                                "cesar Chavez/Congress"                                            "Cesar Chavez/Congress"
 [79] "City Hall / Lavaca & 2nd"                                         "Congress & Cesar Chavez"                                          "Convention Center / 3rd & Trinity"
 [82] "Convention Center / 4th St. @ MetroRail"                          "Convention Center/ 3rd & Trinity"                                 "Customer Service"
 [85] "Davis at Rainey Street"                                           "Dean Keeton & Speedway"                                           "Dean Keeton & Speedway "
 [88] "Dean Keeton & Whitis"                                             "Dean Keeton/Speedway"                                             "Dean Keeton/Speedway "
 [91] "Dean Keeton/Whitis"                                               "East 11th St. & San Marcos"                                       "East 11th St. at Victory Grill"
 [94] "East 11th Street at Victory Grill"                                "East 11th/San Marcos"                                             "East 11th/Victory Grill"
 [97] "East 2nd & Pedernales"                                            "East 2nd/Pedernales"                                              "East 4th & Chicon"
[100] "East 4th/Chicon"                                                  "East 5th/Broadway @ Capital Metro HQ"                             "East 5th/Shady @ Eastside Bus Plaza"
[103] "East 5th/Shady Ln"                                                "East 6th & Pedernales St."                                        "East 6th at Robert Martinez"
[106] "East 6th/Medina"                                                  "East 6th/Pedernales"                                              "East 6th/Robert T. Martinez"
[109] "East 7th & Pleasant Valley"                                       "Eeyore's 2017"                                                    "Eeyore's 2018"
[112] "Electric Drive/Sandra Muraida Way @ Pfluger Ped Bridge"           "Guadalupe & 21st"                                                 "Guadalupe & 6th"
[115] "Guadalupe/West Mall @ University Co-op"                           "Henderson & 9th"                                                  "Hollow Creek & Barton Hills"
[118] "Hollow Creek/Barton Hills"                                        "Lake Austin & Enfield"                                            "Lake Austin Blvd @ Deep Eddy"
[121] "Lake Austin Blvd/Deep Eddy"                                       "Lake Austin/Enfield"                                              "Lakeshore & Pleasant Valley"
[124] "Lakeshore @ Austin Hostel"                                        "Lakeshore/Austin Hostel"                                          "Lakeshore/Pleasant Valley"
[127] "Lavaca & 6th"                                                     "Long Center @ South 1st & Riverside"                              "Main Office"
[130] "MapJam at French Legation"                                        "MapJam at Hops & Grain Brewery"                                   "MapJam at Pan Am Park"
[133] "MapJam at Scoot Inn"                                              "Marketing Event"                                                  "Medina & East 6th"
[136] "Mobile Station"                                                   "Mobile Station @ Bike Fest"                                       "Mobile Station @ Boardwalk Opening Ceremony"
[139] "Mobile Station @ Unplugged"                                       "MoPac Pedestrian Bridge @ Veterans Drive"                         "Nash Hernandez @ RBJ South"
[142] "Nash Hernandez/East @ RBJ South"                                  "Nueces & 26th"                                                    "Nueces & 3rd"
[145] "Nueces @ 3rd"                                                     "Palmer Auditorium"                                                "Pease Park"
[148] "Pfluger Bridge @ W 2nd Street"                                    "Plaza Saltillo"                                                   "Rainey @ River St"
[151] "Rainey St @ Cummings"                                             "Rainey/Cummings"                                                  "Rainey/Davis"
[154] "Re-branding"                                                      "Red River & 8th Street"                                           "Red River @ LBJ Library"
[157] "Red River/Cesar Chavez @ The Fairmont"                            "Repair Shop"                                                      "Republic Square"
[160] "Republic Square @ 5th & Guadalupe"                                "Republic Square @ Federal Courthouse Plaza"                       "Republic Square @ Guadalupe & 4th St."
[163] "Rio Grande & 28th"                                                "Riverside @ S. Lamar"                                             "Riverside/South Lamar"
[166] "Rosewood & Angelina"                                              "Rosewood & Chicon"                                                "Rosewood/Angelina"
[169] "Rosewood/Chicon"                                                  "San Jacinto & 8th Street"                                         "Shop"
[172] "South 1st/Riverside @ Long Center"                                "South Congress & Academy"                                         "South Congress & Barton Springs at the Austin American-Statesman"
[175] "South Congress & Elizabeth"                                       "South Congress & James"                                           "South Congress @ Bouldin Creek"
[178] "South Congress/Academy"                                           "South Congress/Barton Springs @ The Austin American-Statesman"    "South Congress/Elizabeth"
[181] "South Congress/James"                                             "State Capitol @ 14th & Colorado"                                  "State Capitol Visitors Garage @ San Jacinto & 12th"
[184] "State Parking Garage @ Brazos & 18th"                             "Sterzing at Barton Springs"                                       "Sterzing/Barton Springs"
[187] "Stolen"                                                           "Toomey Rd @ South Lamar"                                          "Trinity & 6th Street"
[190] "UT West Mall @ Guadalupe"                                         "Veterans/Atlanta @ MoPac Ped Bridge"                              "Waller & 6th St."
[193] "West & 6th St."                                                   "Zilker Park"                                                      "Zilker Park at Barton Springs & William Barton Drive"
[196] "Zilker Park West"

Oh no, we have a lot of cleaning to do here

tmp = tolower(bikeclean$Checkout.Kiosk)
tmp = gsub("\\.", " ",tmp)
tmp = gsub("&", "/",tmp)
tmp = gsub("street", "",tmp)
tmp = gsub(" st ", "",tmp)
tmp = gsub(" at ", "@",tmp)
tmp = gsub("@", "/",tmp)
tmp = gsub(" ", "",tmp)
tmp = data.frame(tmp)
tmp = separate(data = tmp, col = 1, into = c("1st","2nd","3rd","4th"), sep = "[^[:alnum:]]+")
Expected 4 pieces. Missing pieces filled with `NA` in 1323839 rows [1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, ...].
tmp[is.na(tmp)] <- "ZZZZZ" # Sort doesn't like NA values, so I'm replacing with ZZZZ to go to the end of the row
tmp = data.frame(t(apply(tmp,1,sort))) # Sorts by row
tmp = unite(tmp, united, sep="/")
tmp = gsub("/ZZZZZ", "",tmp$united)
tmp = gsub("3rd/theconventioncenter/trinity","3rd/conventioncenter/trinity",tmp)
tmp = gsub("slamar","southlamar",tmp)
tmp = gsub("bartonsprings/kinneyave","bartonsprings/kinney",tmp)
tmp = gsub("branding/re","rebranding",tmp)
tmp = gsub("guadalupe/op/universityco/westmall","guadalupe/utwestmall",tmp)
tmp = gsub("east6th/roberttmartinez","east6th/robertmartinez",tmp)
bikeclean$Checkout.Kiosk = tmp

Return Kiosk

tmp = tolower(bikeclean$Return.Kiosk)
tmp = gsub("\\.", " ",tmp)
tmp = gsub("&", "/",tmp)
tmp = gsub("street", "",tmp)
tmp = gsub(" st ", "",tmp)
tmp = gsub(" at ", "@",tmp)
tmp = gsub("@", "/",tmp)
tmp = gsub(" ", "",tmp)
tmp = data.frame(tmp)
tmp = separate(data = tmp, col = 1, into = c("1st","2nd","3rd","4th"), sep = "[^[:alnum:]]+")
Expected 4 pieces. Missing pieces filled with `NA` in 1323892 rows [1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, ...].
tmp[is.na(tmp)] <- "ZZZZZ" # Sort doesn't like NA values, so I'm replacing with ZZZZ to go to the end of the row
tmp = data.frame(t(apply(tmp,1,sort))) # Sorts by row
tmp = unite(tmp, united, sep="/")
tmp = gsub("/ZZZZZ", "",tmp$united)
tmp = gsub("3rd/theconventioncenter/trinity","3rd/conventioncenter/trinity",tmp)
tmp = gsub("slamar","southlamar",tmp)
tmp = gsub("bartonsprings/kinneyave","bartonsprings/kinney",tmp)
tmp = gsub("branding/re","rebranding",tmp)
tmp = gsub("guadalupe/op/universityco/westmall","guadalupe/utwestmall",tmp)
tmp = gsub("east6th/roberttmartinez","east6th/robertmartinez",tmp)

Let’s compare the drop off and pickup groups to see if we need to recode anything.

comparison =  data.frame(sort(unique(tmp)),c(sort(unique(bikeclean$Checkout.Kiosk)), NA, NA, NA,NA))
colnames(comparison) <- c("Return", "Checkout")
comparison$Return[!comparison$Return %in% comparison$Checkout]
[1] "acl2019dropoff"  "earthdayatx2017" "fantasyzilker"   "mainshop"        "missing"        
comparison$Checkout[!comparison$Checkout %in% comparison$Return]
[1] "eeyore/s2018" NA             NA             NA             NA

Mainshop should be recoded to shop

tmp = gsub("mainshop","shop",tmp)
bikeclean$Return.Kiosk = tmp

Membership types

I want to encode these as the following:

Single Trip

“$1 Pay by Trip Fall Special”,“Single Trip”,“Try Before You Buy Special”,“$1 Pay by Trip Winter Special”,“RideScout Single Ride”,“Single Trip”,“Single Trip Ride”, “Pay-as-you-ride”,“Single Trip (Pay-as-you-ride)”,“24-Hour Kiosk (Austin B-cycle)”,“24 Hour Walk Up Pass”,“Walk Up”

Daily

“24-Hour-Online (Austin B-cycle)”,“24-Hour Membership (Austin B-cycle)”,“Explorer”,“Explorer ($8 plus tax)”

3-Day

“3-Day Explorer”,“Weekender”,“3-Day Weekender”,“Weekender ($15 plus tax)”

Weekly

“7-Day”,7-Day Membership (Austin B-cycle),“7-Day Membership (Austin B-cycle)”

Monthly

“Local30 ($11 plus tax)”,“Local30”,“Local31”

Annual

“Annual”,“Annual Membership”,“Annual Pass”,“Annual Plus”,“Local365”,“Local365 ($80 plus tax)”,“Local365 Youth (age 13-17 riders)- 1/2,”Local365+Guest Pass“,”Annual“,”Annual Member“,”Annual Membership“,”Annual Membership (Austin B-cycle)“,”Annual Pass (30 minute)“,”Annual Plus Membership“,”Local365- 1/2 off Anniversary Special“,”Local365 Youth (age 13-17 riders)“,Special” “Local365 Youth with helmet (age 13-17 riders)”,“Local365+Guest Pass- 1/2 off Anniversary Special”,“Membership: pay once one-year commitment”

Student

“HT Ram Membership”,“Semester Membership”,“UT Student Membership”,“Semester Membership (Austin B-cycle)”,“U.T. Student Membership”,“U.T. Student Membership”

Event

“ACL 2019 Pass”,“ACL Weekend Pass Special (Austin B-cycle)”,“FunFunFun Fest 3 Day Pass”

Share

“Annual (Broward B-cycle)”,“Annual (Denver B-cycle)”,“Annual (Kansas City B-cycle)”,“Annual (Nashville B-cycle)”,“Annual (San Antonio B-cycle)”,“Annual Member (Houston B-cycle)”,“Annual Membership (Charlotte B-cycle)”,“Annual Membership (GREENbike)”,“Denver B-cycle Founder”,“Heartland Pass (Annual Pay)”,“Madtown Monthly”,“Republic Rider”,“Annual (Cincy Red Bike)”,“Annual (Omaha B-cycle)”,“Annual (Madison B-cycle)”,“Annual (Denver Bike Sharing)”,“Annual Membership (Fort Worth Bike Sharing)”,“Heartland Pass (Monthly Pay)”,“Republic Rider (Annual)”

Other “Aluminum Access”,“Founding Member (Austin B-cycle)”,“Founding Member”

Missing NA, “PROHIBITED”, “RESTRICTED”

bikeclean$Membership.Type[is.na(bikeclean$Membership.Type)] = "missing"
bikeclean$Membership.Type[which(bikeclean$Membership.Type %in% c("PROHIBITED", "RESTRICTED"))]="missing"
bikeclean$Membership.Type[which(bikeclean$Membership.Type %in% c("3-Day Explorer","Weekender","3-Day Weekender","Weekender ($15 plus tax)"))]="3 Day"
bikeclean$Membership.Type[which(bikeclean$Membership.Type %in% c("$1 Pay by Trip Fall Special","Single Trip","Try Before You Buy Special","$1 Pay by Trip Winter Special","RideScout Single Ride","Single Trip ","Single Trip Ride", "Pay-as-you-ride","Single Trip (Pay-as-you-ride)","24-Hour Kiosk (Austin B-cycle)", "24 Hour Walk Up Pass","Walk Up"))]="Single Trip"
bikeclean$Membership.Type[which(bikeclean$Membership.Type %in% c("24-Hour-Online (Austin B-cycle)","24-Hour Membership (Austin B-cycle)","Explorer","Explorer ($8 plus tax)"))]="Daily"
bikeclean$Membership.Type[which(bikeclean$Membership.Type%in%c("7-Day","7-Day Membership (Austin B-cycle)","7-Day Membership (Austin B-cycle)"))]="Weekly"
bikeclean$Membership.Type[which(bikeclean$Membership.Type%in%c("Local30 ($11 plus tax)","Local30","Local31"))]="Monthly"
bikeclean$Membership.Type[which(bikeclean$Membership.Type%in%c("Annual ","Annual Membership ","Annual Pass","Annual Plus","Local365","Local365 ($80 plus tax)","Local365 Youth (age 13-17 riders)- 1/2" ,"Local365+Guest Pass","Annual","Annual Member","Annual Membership","Annual Membership (Austin B-cycle)","Annual Pass (30 minute)","Annual Plus Membership","Local365- 1/2 off Anniversary Special","Local365 Youth (age 13-17 riders)", "Local365 Youth with helmet (age 13-17 riders)","Local365+Guest Pass- 1/2 off Anniversary Special","Membership: pay once  one-year commitment","Local365 Youth (age 13-17 riders)- 1/2 off Special"))]="Annual"
bikeclean$Membership.Type[which(bikeclean$Membership.Type%in%c("HT Ram Membership","Semester Membership","UT Student Membership","Semester Membership (Austin B-cycle)","U.T. Student Membership","U.T. Student Membership"))]="Student"
bikeclean$Membership.Type[which(bikeclean$Membership.Type%in%c("ACL 2019 Pass","ACL Weekend Pass Special (Austin B-cycle)","FunFunFun Fest 3 Day Pass"))]="Event"
bikeclean$Membership.Type[which(bikeclean$Membership.Type%in%c("Aluminum Access","Founding Member (Austin B-cycle)","Founding Member"))]="Other"

bikeclean$Membership.Type[which(bikeclean$Membership.Type%in%c("Annual (Broward B-cycle)","Annual (Denver B-cycle)","Annual (Kansas City B-cycle)","Annual (Nashville B-cycle)","Annual (San Antonio B-cycle)","Annual Member (Houston B-cycle)","Annual Membership (Charlotte B-cycle)","Annual Membership (GREENbike)","Denver B-cycle Founder","Heartland Pass (Annual Pay)","Madtown Monthly","Republic Rider","Annual (Cincy Red Bike)","Annual (Omaha B-cycle)","Annual (Madison B-cycle)","Annual (Denver Bike Sharing)","Annual Membership (Fort Worth Bike Sharing)","Heartland Pass (Monthly Pay)","Republic Rider (Annual)", "Annual Membership (Indy - Pacers Bikeshare )", "Annual (Boulder B-cycle)"))]="Share"
sort(unique(bikeclean$Membership.Type))
 [1] "3 Day"       "Annual"      "Daily"       "Event"       "missing"     "Monthly"     "Other"       "Share"       "Single Trip" "Student"
[11] "Weekly"

Looking good! I might try and predict our missing membership types if I have time.

Merging our Datasets

merged = merge(bikeclean,weatherclean,by.x = "Checkout.Date",by.y ="Date")
saveRDS(merged,file = 'merged.rds')

Now I don’t have to run everything above this EVERY time I need to start over.

merged = readRDS("merged.rds")
merged$Membership.Type=factor(merged$Membership.Type)

Data visualization

ggplot(merged)+
  geom_point(aes(x = Checkout.Date, y=round(Trip.Duration.Minutes/60)))+
  geom_hline(yintercept=1,color = "red")

Trips are expected to be at 1 hour in length. Any more than that and there is a fine associated with each minute over you ride. as time has gone on, more people aren’t checking their bikes in on time.

I wonder what’s up with the weird gaps in 2016.

ggplot(merged[which(year(merged$Checkout.Date)==2016),])+
    geom_point(aes(x = Checkout.Date, y=round(Trip.Duration.Minutes/60)))

ggplot(merged[which(year(merged$Checkout.Date)==2016 & month(merged$Checkout.Date)==4),])+
      geom_point(aes(x = Checkout.Date, y=round(Trip.Duration.Minutes/60)))

merged[which(year(merged$Checkout.Date)==2016 & month(merged$Checkout.Date)==4),]

Great, no data for that month.

merged[which(year(merged$Checkout.Date)==2016 & month(merged$Checkout.Date)==12),]

Same with December.

ggplot(merged)+
  geom_bar(aes(x=factor(month(Checkout.Date))), fill = "blue")+
  facet_wrap(~year(Checkout.Date))

We can see there is a cyclical nature to the number of trips taken per month. Intuitively, there are more riders when the weather is nice.

summary(merged$AvgTemp)
   Min. 1st Qu.  Median    Mean 3rd Qu.    Max.
  -9.20   17.30   22.40   21.81   27.20   34.00 
ggplot(merged)+
  geom_histogram(aes(x= AvgTemp), bins = 45, fill = "blue")

Most people ride between and 12 and 32 degrees Celsius

merged %>%
  group_by(Checkout.Kiosk) %>%
  summarise(Departing_Bikes = length(Checkout.Kiosk)) %>% arrange(.,desc(Departing_Bikes))
merged %>%
  ggplot() +
  geom_bar(aes(x=Checkout.Kiosk), fill = "red")+
  theme(axis.title.x=element_blank(), axis.text.x=element_blank(), axis.ticks.x=element_blank())

Bikes leave the campus Speedway at a very high rate

merged %>%
  ggplot() +
  geom_bar(aes(x=Return.Kiosk), fill = "blue")+
  theme(axis.title.x=element_blank(), axis.text.x=element_blank(), axis.ticks.x=element_blank())

merged %>%
  group_by(Return.Kiosk) %>%
  summarise(Departing_Bikes = length(Return.Kiosk)) %>% arrange(.,desc(Departing_Bikes))

Even more are returned there

Daily Differential Requiring Human Intervention

checkout = merged %>% group_by(Checkout.Date, Checkout.Kiosk) %>% tally() %>% spread(Checkout.Date, n)
checkout = checkout[-which(checkout$Checkout.Kiosk == "eeyore/s2018"),]
return = merged %>% group_by(Checkout.Date, Return.Kiosk) %>% tally() %>% spread(Checkout.Date, n)
return = return[-which(!return$Return.Kiosk %in% checkout$Checkout.Kiosk),]
checkout[is.na(checkout)] = 0
return[is.na(return)]= 0
diff = data.frame(return$Return.Kiosk,return[,-1]-checkout[,-1])
diff
daily_diff = data.frame(colSums(abs(diff[,-1])))
daily_diff <- rownames_to_column(daily_diff, "Date")
daily_diff$Date = gsub( "X", "", daily_diff$Date)
daily_diff$Date = as.Date(strptime(daily_diff$Date, format = '%Y.%m.%d'))
colnames(daily_diff) = c("Date","Diff")
daily_diff
ggplot(daily_diff)+
  geom_bar(aes(x=Date, y = Diff), stat = "identity")

daily_diff = merge(daily_diff,weatherclean,by.x = "Date",by.y ="Date")
daily_diff$month = month(daily_diff$Date)
xgrid = seq(-10,50,.001)
ggplot(daily_diff) +
  geom_point(aes(x = AvgTemp, y = Diff, color =factor(month(Date))))

This seems like one of those things we would want to predict so that we can know staffing levels. Let’s try to predict it with a random forest.

Random Forest

head(daily_diff)
set.seed(123)
train = sample (1:nrow(daily_diff), nrow(daily_diff)/2)
rf.dd= randomForest(Diff ~ Date + AvgTemp,data=daily_diff, subset=train)
yhat.rf = predict(rf.dd ,newdata=daily_diff[- train ,])
mean((yhat.rf-daily_diff[-train, "Diff"])^2)
[1] 2518.162
ggplot()+
  geom_point(aes(x=daily_diff$Diff[-train],y = yhat.rf))+
  geom_abline(color = "red")

summary(daily_diff)
      Date                 Diff          AvgTemp          month
 Min.   :2013-12-21   Min.   :  6.0   Min.   :-9.20   Min.   : 1.000
 1st Qu.:2015-09-24   1st Qu.: 90.0   1st Qu.:15.00   1st Qu.: 3.000
 Median :2017-08-26   Median :118.0   Median :22.10   Median : 6.000
 Mean   :2017-08-03   Mean   :131.3   Mean   :20.84   Mean   : 6.393
 3rd Qu.:2019-05-29   3rd Qu.:154.0   3rd Qu.:27.60   3rd Qu.: 9.000
 Max.   :2021-02-28   Max.   :726.0   Max.   :34.00   Max.   :12.000

Not terrible, but there are some areas where the model gets it pretty wrong

Let’s try boosting

set.seed(12)
boost.dd=gbm(Diff~AvgTemp+month(Date)+year(Date)+day(Date),data=daily_diff[train ,], distribution="gaussian",n.trees=5000, shrinkage = .01,interaction.depth = 3)
best.iter <- gbm.perf(boost.dd, method = "OOB", plot = FALSE)
OOB generally underestimates the optimal number of iterations although predictive performance is reasonably competitive. Using cv_folds>1 when calling gbm usually results in improved predictive performance.
yhat.boost=predict (boost.dd ,newdata =daily_diff[-train ,], n.trees=best.iter)
mean((yhat.boost-daily_diff[-train, "Diff"])^2)
[1] 3167.117
ggplot()+
  geom_point(aes(x=daily_diff$Diff[-train],y = yhat.boost))+
  geom_abline(color = "red")

daily_diff[daily_diff$Diff>300, 'Date']
 [1] "2014-03-12" "2014-03-14" "2014-03-15" "2014-10-03" "2014-10-04" "2014-10-05" "2014-10-10" "2014-10-11" "2014-10-12" "2015-03-13" "2015-03-14"
[12] "2015-03-15" "2015-03-16" "2015-03-17" "2015-03-18" "2015-03-19" "2015-03-20" "2015-10-02" "2015-10-03" "2015-10-04" "2015-10-09" "2015-10-10"
[23] "2015-10-11" "2016-01-23" "2016-01-30" "2016-01-31" "2016-03-12" "2016-03-13" "2016-03-16" "2016-03-19" "2016-09-30" "2016-10-01" "2016-10-02"
[34] "2016-10-07" "2016-10-08" "2016-10-09" "2017-03-13" "2017-03-14" "2017-03-15" "2017-03-16" "2017-03-17" "2017-03-18" "2017-10-06" "2017-10-07"
[45] "2017-10-08" "2017-10-13" "2017-10-14" "2017-10-15" "2018-02-19" "2018-03-01" "2018-03-02" "2018-03-06" "2018-03-08" "2018-03-09" "2018-03-10"
[56] "2018-03-11" "2018-03-13" "2018-03-14" "2018-03-15" "2018-03-16" "2018-03-17" "2018-03-18" "2018-03-20" "2018-03-21" "2018-03-22" "2018-03-23"
[67] "2018-03-28" "2018-03-29" "2018-04-02" "2018-04-04" "2018-04-06" "2018-04-10" "2018-04-11" "2018-04-12" "2018-04-13" "2018-04-17" "2018-04-18"
[78] "2018-04-19" "2018-04-20" "2018-04-23" "2018-04-26" "2018-04-27" "2018-05-01" "2018-05-03" "2018-05-08" "2018-10-05" "2018-10-06" "2018-10-07"
[89] "2018-10-13"

ANN Try

library(neuralnet)
library(NeuralNetTools)
daily_diff$year = year(daily_diff$Date)
daily_diff$day = day(daily_diff$Date)
dd.scaled <- as.data.frame(scale(daily_diff[,-1]))
min.diff <- min(daily_diff$Diff)
max.diff <- max(daily_diff$Diff)
dd.scaled
dd.scaled$Diff <- scale(daily_diff$Diff, center = min.diff, scale = max.diff - min.diff)
dd.split <- sample(dim(daily_diff)[1],dim(daily_diff)[1]/2 )
# Train-test split
dd.train.scaled <- dd.scaled[dd.split, ]
dd.test.scaled <- dd.scaled[-dd.split, ]
generate.full.fmla<- function(df, response){
  names(df)[!(names(df) == response)]%>%
    paste(.,collapse = "+")%>%
     paste(response, "~", .)%>%
    formula(.)
}
dd.nn.fmla <- generate.full.fmla(dd.train.scaled, "Diff")
dd.nn.5.3 <- neuralnet(dd.nn.fmla
                           , data=dd.train.scaled
                           , hidden=c(5,3)
                           , linear.output=TRUE)
dd.nn.8 <- neuralnet(dd.nn.fmla
                           , data=dd.train.scaled
                           , hidden=8
                           , linear.output=TRUE)
rf.dd= randomForest(dd.nn.fmla,data=dd.train.scaled)

fitness.measures <- function(test, model, response){
  data.frame(y = test[, response], yhat = predict(model, newdata = test))%>%
    summarize(MSE = sum((y-yhat)^2)/n(), MAD = sum(abs(y - yhat))/n())%>%
    mutate(RMSE = sqrt(MSE))
}
fitness.measures(dd.test.scaled, dd.nn.5.3, "Diff")
fitness.measures(dd.test.scaled, dd.nn.8, "Diff")
fitness.measures(dd.test.scaled, rf.dd, "Diff")
models = list()

for (i in 3:12){
  nn <- neuralnet(dd.nn.fmla
                           , data=dd.train.scaled
                           , hidden= i
                           , linear.output=TRUE)
  models[[i]] <- nn
}
  
mse = list()
for (i in 3:12) {
 mse[i] <- (fitness.measures(dd.test.scaled, models[[i]], "Diff")[1] * ((max.diff-min.diff)**2))
}

mse[1] <- fitness.measures(dd.test.scaled, dd.nn.5.3, "Diff")[1] * ((max.diff-min.diff)**2)
mse[2] <- fitness.measures(dd.test.scaled, rf.dd, "Diff")[1] * ((max.diff-min.diff)**2)

mse
[[1]]
[1] 4037.12

[[2]]
[1] 3321.5

[[3]]
[1] 4496.449

[[4]]
[1] 4440.882

[[5]]
[1] 4367.814

[[6]]
[1] 4364.864

[[7]]
[1] 4650.306

[[8]]
[1] 4138.011

[[9]]
[1] 3994.522

[[10]]
[1] 3924.122

[[11]]
[1] 4297.862

[[12]]
[1] 4095.124
NeuralNetTools::garson(models[[10]])

NeuralNetTools::plotnet(models[[10]])

Trip duration

ggplot(merged)+
  geom_point(aes(x=Checkout.Kiosk, y = Trip.Duration.Minutes ))+
  theme(axis.title.x=element_blank(), axis.text.x=element_blank(), axis.ticks.x=element_blank())

Some stations don’t have long trips associated with them at all, while others have TONS of long trips associated with them.

ggplot(merged)+
  geom_point(aes(y=Membership.Type, x = Trip.Duration.Minutes ))+
  geom_vline(xintercept = 60, color = "red")

Single trips run long the most often, but there a lot of late trips period.

merged$late = ifelse(merged$Trip.Duration.Minutes > 60,1 ,0)
ggplot(merged)+
  geom_bar(aes(y = Membership.Type,fill = factor(late)))

ggplot(merged)+
  geom_bar(aes(x = Checkout.Kiosk,fill = factor(late)))+
  theme(axis.title.x=element_blank(), axis.text.x=element_blank(), axis.ticks.x=element_blank())

head(merged)
temp_merged = merged#[year(merged$Checkout.Date)>2018,]
temp_merged$Checkout.Kiosk = factor(temp_merged$Checkout.Kiosk)
temp_merged$hour = hour(temp_merged$Checkout.Time)
temp_merged$Membership.Type = factor(temp_merged$Membership.Type)
set.seed(123)
train = sample (1:nrow(temp_merged), nrow(temp_merged)/2)
set.seed(12)
boost.merged=gbm(Trip.Duration.Minutes~Membership.Type+hour + Checkout.Kiosk+AvgTemp,data=temp_merged[train ,], distribution="gaussian",n.trees=500, shrinkage = .1)
Error in gbm(Trip.Duration.Minutes ~ Membership.Type + hour + Checkout.Kiosk +  :
  could not find function "gbm"
summary(boost.merged)

gbm.perf(boost.merged, method = "OOB")
OOB generally underestimates the optimal number of iterations although predictive performance is reasonably competitive. Using cv_folds>1 when calling gbm usually results in improved predictive performance.
[1] 34
attr(,"smoother")
Call:
loess(formula = object$oobag.improve ~ x, enp.target = min(max(4,
    length(x)/10), 50))

Number of Observations: 500
Equivalent Number of Parameters: 39.85
Residual Standard Error: 4.938 

pred = predict.gbm(object = boost.merged,newdata = temp_merged[-train,], n.trees = 34)
mean((pred - temp_merged$Trip.Duration.Minutes[-train])^2)
[1] 54794.91
ggplot()+
  geom_point(aes(x=temp_merged$Trip.Duration.Minutes[-train], y = pred))+
  geom_abline()

head(temp_merged)
boost.merged=gbm(late~Membership.Type+hour + Checkout.Kiosk+AvgTemp,data=temp_merged[train ,], distribution="bernoulli",n.trees=500, shrinkage = .1)

summary(boost.merged)

prob = predict(boost.merged, newdata = temp_merged[-train ,], type = "response")
Using 500 trees...
yhat = ifelse(prob >.5,1,0)
sum(yhat)
[1] 1
hist(prob)

yhat = ifelse(prob >.5,1,0)
cm = t(table(yhat, temp_merged$late[-train]))
cm
   yhat
         0      1
  0 103124      1
  1  12738      0
sum(diag(cm))/sum(cm) #Accuracy
[1] 0.8900512
cm[1,1]/sum(cm[1, c(1,2)]) #Correct rate of negative predicted values
[1] 0.9999903
cm[2,2]/sum(cm[2, c(1,2)]) #Correct rate of positive predicted value
[1] 0
yhat = ifelse(prob >.15,1,0)
cm = t(table(yhat, temp_merged$late[-train]))
cm
   yhat
        0     1
  0 74522 28603
  1  3786  8952
sum(diag(cm))/sum(cm) #Accuracy
[1] 0.7204543
cm[1,1]/sum(cm[1, c(1,2)]) #Correct rate of negative predicted values
[1] 0.7226376
cm[2,2]/sum(cm[2, c(1,2)]) #Correct rate of positive predicted value
[1] 0.7027791
LS0tDQp0aXRsZTogIkF1c3RpbiBCaWtlIERhdGEgRXhwbG9yYXRpb24iDQpvdXRwdXQ6IGh0bWxfbm90ZWJvb2sNCi0tLQ0KDQpEYXRhIHNldCBhbmQgZGVzY3JpcHRpb24gY2FuIGJlIGZvdW5kIFtoZXJlXShodHRwczovL2RhdGEuYXVzdGludGV4YXMuZ292L1RyYW5zcG9ydGF0aW9uLWFuZC1Nb2JpbGl0eS9BdXN0aW4tTWV0cm9CaWtlLVRyaXBzL3R5ZmgtNXI4cykNCg0KR2l0aHViIHBhZ2Ugd2l0aCBjbGVhbmVkIHVwIGRhdGEgYW5kIHByZXNlbnRhdGlvbiBbaGVyZV0oaHR0cHM6Ly9naXRodWIuY29tL25kbGVkL0F1c3RpbkJpa2VzKQ0KDQojIExpYnJhcmllcyBJIG1pZ2h0IHVzZQ0KDQpgYGB7cn0NCmxpYnJhcnkoSVNMUikNCmxpYnJhcnkodGlkeXZlcnNlKQ0KbGlicmFyeShyYW5kb21Gb3Jlc3QpDQpsaWJyYXJ5KGdibSkNCmxpYnJhcnkoTUFTUykNCmxpYnJhcnkobHVicmlkYXRlKQ0KbGlicmFyeSh6b28pDQpsaWJyYXJ5KEdHYWxseSkNCmxpYnJhcnkoZTEwNzEpICNTVk0gYW5kIE5CIGxpYnJhcnkNCmBgYA0KDQojIExvYWRpbmcgaW4gdGhlIERhdGENCg0KYGBge3J9DQpiaWtlZGF0YSA9IHJlYWQuY3N2KCJBdXN0aW5fTWV0cm9CaWtlX1RyaXBzLmNzdiIpDQp3ZWF0aGVyZGF0YSA9IHJlYWQuY3N2KCJhdXN0aW5kYWlseS5jc3YiKQ0KYGBgDQoNCmBgYHtyfQ0KYmlrZWRhdGENCmBgYA0KYGBge3J9DQp3ZWF0aGVyZGF0YQ0KYGBgDQoNCg0KIyBEYXRhIENsZWFuaW5nDQoNCiMjIFdlYXRoZXIgRGF0YQ0KYGBge3J9DQp3ZWF0aGVyY2xlYW4gPSBmaWx0ZXIod2VhdGhlcmRhdGEsIHllYXIoWDE5MzguMDYuMDEpPjIwMTIpDQp3ZWF0aGVyY2xlYW4gPSB3ZWF0aGVyY2xlYW5bLGMoMSwyKV0NCmNvbG5hbWVzKHdlYXRoZXJjbGVhbikgPC0gYygiRGF0ZSIsIkF2Z1RlbXAiKQ0Kd2VhdGhlcmNsZWFuJERhdGUgPSBhcy5EYXRlKHN0cnB0aW1lKHdlYXRoZXJjbGVhbiREYXRlLCBmb3JtYXQgPSAnJVktJW0tJWQnKSkNCmBgYA0KDQpgYGB7cn0NCnN1bW1hcnkod2VhdGhlcmNsZWFuKQ0KYGBgDQpCdXQgd2UgY2FuIHNlZSB3ZSBoYXZlIDgwIGRhdGVzIHdpdGggbWlzc2luZyB0ZW1wZXJhdHVyZSB2YWx1ZXMuIEkgd291bGQgbGlrZSB0byBpbXB1dGUgYW4gYXZlcmFnZSBhcm91bmQgaXQsIGJ1dCBpcyB0aGF0IGEgc291bmQgc3RyYXRlZ3k/DQoNCmBgYHtyfQ0Kc2V0LnNlZWQoMTIzKQ0Kd2VhdGhlcmNsZWFubm49bmEub21pdCh3ZWF0aGVyY2xlYW4pDQpmYWtld2VhdGhlciA9IHdlYXRoZXJjbGVhbm5uDQpuYXMgPSBzYW1wbGUgKDE6bnJvdyh3ZWF0aGVyY2xlYW5ubiksIG5yb3cod2VhdGhlcmNsZWFubm4pKjAuMDI5MzQ3MDMpICMgVGhlIHNhbWUgcmF0ZSBvZiBtaXNzaW5nIHZhbHVlcyBhcyBpbiBvdXIgb3JpZ2luYWwgZGF0YSBzZXQNCmZha2V3ZWF0aGVyJEF2Z1RlbXBbbmFzXSA8LSBOQQ0KZmFrZXdlYXRoZXIkQXZnVGVtcCA9IChuYS5sb2NmKGZha2V3ZWF0aGVyJEF2Z1RlbXApICsgcmV2KG5hLmxvY2YocmV2KGZha2V3ZWF0aGVyJEF2Z1RlbXApKSkpLzIgIyBGaWxscyBpbiBtaXNzaW5nIHZhbHVlcyB3aXRoIHRoZSBhdmVyYWdlIG9mIHRoZSB3ZWF0aGVyIHZhbHVlcyBvbiBlaXRoZXIgc2lkZQ0KbWVhbigod2VhdGhlcmNsZWFubm4kQXZnVGVtcFtuYXNdLWZha2V3ZWF0aGVyJEF2Z1RlbXBbbmFzXSleMikNCmBgYA0KDQpHcmVhdCEgV2UgYXJlIGluIGEgcmVhc29uYWJsZSByYW5nZSBvZiB0aGUgdHJ1ZSB0ZW1wZXJhdHVyZSBhbmQgY2FuIGFwcGx5IHRoaXMgbWV0aG9kIHRvIG91ciBkYXRhc2V0Lg0KDQpgYGB7cn0NCndlYXRoZXJjbGVhbiRBdmdUZW1wID0gKG5hLmxvY2Yod2VhdGhlcmNsZWFuJEF2Z1RlbXApICsgcmV2KG5hLmxvY2YocmV2KHdlYXRoZXJjbGVhbiRBdmdUZW1wKSkpKS8yDQpgYGANCg0KYGBge3J9DQp3ZWF0aGVyY2xlYW4NCmBgYA0KDQoNCiMjIEJpa2UgZGF0YQ0KYGBge3J9DQpiaWtlY2xlYW4gPSBiaWtlZGF0YVssYygyLDQsNSw3LDksMTApXQ0KYmlrZWNsZWFuW2Jpa2VjbGVhbj09IiJdIDwtIE5BDQpiaWtlY2xlYW4kQ2hlY2tvdXQuVGltZT1obXMoYmlrZWNsZWFuJENoZWNrb3V0LlRpbWUpDQpiaWtlY2xlYW4kQ2hlY2tvdXQuRGF0ZSA9IGFzLkRhdGUoYmlrZWNsZWFuJENoZWNrb3V0LkRhdGUsZm9ybWF0PSclbS8lZC8lWScpDQpgYGANCg0KYGBge3J9DQpzdW1tYXJ5KChiaWtlY2xlYW4pKQ0KYGBgDQoNCiMjIyBDaGVja291dCBLaW9zaw0KDQpgYGB7cn0NCnNvcnQodW5pcXVlKGJpa2VjbGVhbiRDaGVja291dC5LaW9zaykpDQpgYGANCk9oIG5vLCB3ZSBoYXZlIGEgbG90IG9mIGNsZWFuaW5nIHRvIGRvIGhlcmUNCg0KYGBge3J9DQp0bXAgPSB0b2xvd2VyKGJpa2VjbGVhbiRDaGVja291dC5LaW9zaykNCnRtcCA9IGdzdWIoIlxcLiIsICIgIix0bXApDQp0bXAgPSBnc3ViKCImIiwgIi8iLHRtcCkNCnRtcCA9IGdzdWIoInN0cmVldCIsICIiLHRtcCkNCnRtcCA9IGdzdWIoIiBzdCAiLCAiIix0bXApDQp0bXAgPSBnc3ViKCIgYXQgIiwgIkAiLHRtcCkNCnRtcCA9IGdzdWIoIkAiLCAiLyIsdG1wKQ0KdG1wID0gZ3N1YigiICIsICIiLHRtcCkNCmBgYA0KDQpgYGB7cn0NCnRtcCA9IGRhdGEuZnJhbWUodG1wKQ0KdG1wID0gc2VwYXJhdGUoZGF0YSA9IHRtcCwgY29sID0gMSwgaW50byA9IGMoIjFzdCIsIjJuZCIsIjNyZCIsIjR0aCIpLCBzZXAgPSAiW15bOmFsbnVtOl1dKyIpDQp0bXBbaXMubmEodG1wKV0gPC0gIlpaWlpaIiAjIFNvcnQgZG9lc24ndCBsaWtlIE5BIHZhbHVlcywgc28gSSdtIHJlcGxhY2luZyB3aXRoIFpaWlogdG8gZ28gdG8gdGhlIGVuZCBvZiB0aGUgcm93DQp0bXAgPSBkYXRhLmZyYW1lKHQoYXBwbHkodG1wLDEsc29ydCkpKSAjIFNvcnRzIGJ5IHJvdw0KdG1wID0gdW5pdGUodG1wLCB1bml0ZWQsIHNlcD0iLyIpDQp0bXAgPSBnc3ViKCIvWlpaWloiLCAiIix0bXAkdW5pdGVkKQ0KYGBgDQoNCmBgYHtyfQ0KdG1wID0gZ3N1YigiM3JkL3RoZWNvbnZlbnRpb25jZW50ZXIvdHJpbml0eSIsIjNyZC9jb252ZW50aW9uY2VudGVyL3RyaW5pdHkiLHRtcCkNCnRtcCA9IGdzdWIoInNsYW1hciIsInNvdXRobGFtYXIiLHRtcCkNCnRtcCA9IGdzdWIoImJhcnRvbnNwcmluZ3Mva2lubmV5YXZlIiwiYmFydG9uc3ByaW5ncy9raW5uZXkiLHRtcCkNCnRtcCA9IGdzdWIoImJyYW5kaW5nL3JlIiwicmVicmFuZGluZyIsdG1wKQ0KdG1wID0gZ3N1YigiZ3VhZGFsdXBlL29wL3VuaXZlcnNpdHljby93ZXN0bWFsbCIsImd1YWRhbHVwZS91dHdlc3RtYWxsIix0bXApDQp0bXAgPSBnc3ViKCJlYXN0NnRoL3JvYmVydHRtYXJ0aW5leiIsImVhc3Q2dGgvcm9iZXJ0bWFydGluZXoiLHRtcCkNCmBgYA0KDQpgYGB7cn0NCmJpa2VjbGVhbiRDaGVja291dC5LaW9zayA9IHRtcA0KYGBgDQoNCg0KIyMjIFJldHVybiBLaW9zaw0KDQpgYGB7cn0NCnRtcCA9IHRvbG93ZXIoYmlrZWNsZWFuJFJldHVybi5LaW9zaykNCnRtcCA9IGdzdWIoIlxcLiIsICIgIix0bXApDQp0bXAgPSBnc3ViKCImIiwgIi8iLHRtcCkNCnRtcCA9IGdzdWIoInN0cmVldCIsICIiLHRtcCkNCnRtcCA9IGdzdWIoIiBzdCAiLCAiIix0bXApDQp0bXAgPSBnc3ViKCIgYXQgIiwgIkAiLHRtcCkNCnRtcCA9IGdzdWIoIkAiLCAiLyIsdG1wKQ0KdG1wID0gZ3N1YigiICIsICIiLHRtcCkNCmBgYA0KDQpgYGB7cn0NCnRtcCA9IGRhdGEuZnJhbWUodG1wKQ0KdG1wID0gc2VwYXJhdGUoZGF0YSA9IHRtcCwgY29sID0gMSwgaW50byA9IGMoIjFzdCIsIjJuZCIsIjNyZCIsIjR0aCIpLCBzZXAgPSAiW15bOmFsbnVtOl1dKyIpDQp0bXBbaXMubmEodG1wKV0gPC0gIlpaWlpaIiAjIFNvcnQgZG9lc24ndCBsaWtlIE5BIHZhbHVlcywgc28gSSdtIHJlcGxhY2luZyB3aXRoIFpaWlogdG8gZ28gdG8gdGhlIGVuZCBvZiB0aGUgcm93DQp0bXAgPSBkYXRhLmZyYW1lKHQoYXBwbHkodG1wLDEsc29ydCkpKSAjIFNvcnRzIGJ5IHJvdw0KdG1wID0gdW5pdGUodG1wLCB1bml0ZWQsIHNlcD0iLyIpDQp0bXAgPSBnc3ViKCIvWlpaWloiLCAiIix0bXAkdW5pdGVkKQ0KYGBgDQoNCmBgYHtyfQ0KdG1wID0gZ3N1YigiM3JkL3RoZWNvbnZlbnRpb25jZW50ZXIvdHJpbml0eSIsIjNyZC9jb252ZW50aW9uY2VudGVyL3RyaW5pdHkiLHRtcCkNCnRtcCA9IGdzdWIoInNsYW1hciIsInNvdXRobGFtYXIiLHRtcCkNCnRtcCA9IGdzdWIoImJhcnRvbnNwcmluZ3Mva2lubmV5YXZlIiwiYmFydG9uc3ByaW5ncy9raW5uZXkiLHRtcCkNCnRtcCA9IGdzdWIoImJyYW5kaW5nL3JlIiwicmVicmFuZGluZyIsdG1wKQ0KdG1wID0gZ3N1YigiZ3VhZGFsdXBlL29wL3VuaXZlcnNpdHljby93ZXN0bWFsbCIsImd1YWRhbHVwZS91dHdlc3RtYWxsIix0bXApDQp0bXAgPSBnc3ViKCJlYXN0NnRoL3JvYmVydHRtYXJ0aW5leiIsImVhc3Q2dGgvcm9iZXJ0bWFydGluZXoiLHRtcCkNCmBgYA0KDQpMZXQncyBjb21wYXJlIHRoZSBkcm9wIG9mZiBhbmQgcGlja3VwIGdyb3VwcyB0byBzZWUgaWYgd2UgbmVlZCB0byByZWNvZGUgYW55dGhpbmcuDQoNCmBgYHtyfQ0KY29tcGFyaXNvbiA9ICBkYXRhLmZyYW1lKHNvcnQodW5pcXVlKHRtcCkpLGMoc29ydCh1bmlxdWUoYmlrZWNsZWFuJENoZWNrb3V0Lktpb3NrKSksIE5BLCBOQSwgTkEsTkEpKQ0KY29sbmFtZXMoY29tcGFyaXNvbikgPC0gYygiUmV0dXJuIiwgIkNoZWNrb3V0IikNCmBgYA0KDQpgYGB7cn0NCmNvbXBhcmlzb24kUmV0dXJuWyFjb21wYXJpc29uJFJldHVybiAlaW4lIGNvbXBhcmlzb24kQ2hlY2tvdXRdDQpjb21wYXJpc29uJENoZWNrb3V0WyFjb21wYXJpc29uJENoZWNrb3V0ICVpbiUgY29tcGFyaXNvbiRSZXR1cm5dDQpgYGANCk1haW5zaG9wIHNob3VsZCBiZSByZWNvZGVkIHRvIHNob3ANCg0KDQpgYGB7cn0NCnRtcCA9IGdzdWIoIm1haW5zaG9wIiwic2hvcCIsdG1wKQ0KYmlrZWNsZWFuJFJldHVybi5LaW9zayA9IHRtcA0KYGBgDQoNCg0KDQojIyMgTWVtYmVyc2hpcCB0eXBlcw0KDQpJIHdhbnQgdG8gZW5jb2RlIHRoZXNlIGFzIHRoZSBmb2xsb3dpbmc6DQoNCipTaW5nbGUgVHJpcCoNCg0KIiQxIFBheSBieSBUcmlwIEZhbGwgU3BlY2lhbCIsIlNpbmdsZSBUcmlwIiwiVHJ5IEJlZm9yZSBZb3UgQnV5IFNwZWNpYWwiLCIkMSBQYXkgYnkgVHJpcCBXaW50ZXIgU3BlY2lhbCIsIlJpZGVTY291dCBTaW5nbGUgUmlkZSIsIlNpbmdsZSBUcmlwICIsIlNpbmdsZSBUcmlwIFJpZGUiLCAiUGF5LWFzLXlvdS1yaWRlIiwiU2luZ2xlIFRyaXAgKFBheS1hcy15b3UtcmlkZSkiLCIyNC1Ib3VyIEtpb3NrIChBdXN0aW4gQi1jeWNsZSkiLCIyNCBIb3VyIFdhbGsgVXAgUGFzcyIsIldhbGsgVXAiDQoNCipEYWlseSoNCg0KIjI0LUhvdXItT25saW5lIChBdXN0aW4gQi1jeWNsZSkiLCIyNC1Ib3VyIE1lbWJlcnNoaXAgKEF1c3RpbiBCLWN5Y2xlKSIsIkV4cGxvcmVyIiwiRXhwbG9yZXIgKCQ4IHBsdXMgdGF4KSINCg0KKjMtRGF5Kg0KDQoiMy1EYXkgRXhwbG9yZXIiLCJXZWVrZW5kZXIiLCIzLURheSBXZWVrZW5kZXIiLCJXZWVrZW5kZXIgKCQxNSBwbHVzIHRheCkiDQoNCipXZWVrbHkqDQoNCiI3LURheSIsNy1EYXkgTWVtYmVyc2hpcCAoQXVzdGluIEItY3ljbGUpLCI3LURheSBNZW1iZXJzaGlwIChBdXN0aW4gQi1jeWNsZSkiDQoNCipNb250aGx5Kg0KDQoiTG9jYWwzMCAoJDExIHBsdXMgdGF4KSIsIkxvY2FsMzAiLCJMb2NhbDMxIg0KDQoqQW5udWFsKg0KDQoiQW5udWFsICIsIkFubnVhbCBNZW1iZXJzaGlwICIsIkFubnVhbCBQYXNzIiwiQW5udWFsIFBsdXMiLCJMb2NhbDM2NSIsIkxvY2FsMzY1ICgkODAgcGx1cyB0YXgpIiwiTG9jYWwzNjUgWW91dGggKGFnZSAxMy0xNyByaWRlcnMpLSAxLzIsIkxvY2FsMzY1K0d1ZXN0IFBhc3MiLCJBbm51YWwiLCJBbm51YWwgTWVtYmVyIiwiQW5udWFsIE1lbWJlcnNoaXAiLCJBbm51YWwgTWVtYmVyc2hpcCAoQXVzdGluIEItY3ljbGUpIiwiQW5udWFsIFBhc3MgKDMwIG1pbnV0ZSkiLCJBbm51YWwgUGx1cyBNZW1iZXJzaGlwIiwiTG9jYWwzNjUtIDEvMiBvZmYgQW5uaXZlcnNhcnkgU3BlY2lhbCIsIkxvY2FsMzY1IFlvdXRoIChhZ2UgMTMtMTcgcmlkZXJzKSIsU3BlY2lhbCIgIkxvY2FsMzY1IFlvdXRoIHdpdGggaGVsbWV0IChhZ2UgMTMtMTcgcmlkZXJzKSIsIkxvY2FsMzY1K0d1ZXN0IFBhc3MtIDEvMiBvZmYgQW5uaXZlcnNhcnkgU3BlY2lhbCIsIk1lbWJlcnNoaXA6IHBheSBvbmNlICBvbmUteWVhciBjb21taXRtZW50Ig0KDQoqU3R1ZGVudCoNCg0KIkhUIFJhbSBNZW1iZXJzaGlwIiwiU2VtZXN0ZXIgTWVtYmVyc2hpcCIsIlVUIFN0dWRlbnQgTWVtYmVyc2hpcCIsIlNlbWVzdGVyIE1lbWJlcnNoaXAgKEF1c3RpbiBCLWN5Y2xlKSIsIlUuVC4gU3R1ZGVudCBNZW1iZXJzaGlwIiwiVS5ULiBTdHVkZW50IE1lbWJlcnNoaXAiDQoNCipFdmVudCoNCg0KIkFDTCAyMDE5IFBhc3MiLCJBQ0wgV2Vla2VuZCBQYXNzIFNwZWNpYWwgKEF1c3RpbiBCLWN5Y2xlKSIsIkZ1bkZ1bkZ1biBGZXN0IDMgRGF5IFBhc3MiDQoNCipTaGFyZSoNCg0KIkFubnVhbCAoQnJvd2FyZCBCLWN5Y2xlKSIsIkFubnVhbCAoRGVudmVyIEItY3ljbGUpIiwiQW5udWFsIChLYW5zYXMgQ2l0eSBCLWN5Y2xlKSIsIkFubnVhbCAoTmFzaHZpbGxlIEItY3ljbGUpIiwiQW5udWFsIChTYW4gQW50b25pbyBCLWN5Y2xlKSIsIkFubnVhbCBNZW1iZXIgKEhvdXN0b24gQi1jeWNsZSkiLCJBbm51YWwgTWVtYmVyc2hpcCAoQ2hhcmxvdHRlIEItY3ljbGUpIiwiQW5udWFsIE1lbWJlcnNoaXAgKEdSRUVOYmlrZSkiLCJEZW52ZXIgQi1jeWNsZSBGb3VuZGVyIiwiSGVhcnRsYW5kIFBhc3MgKEFubnVhbCBQYXkpIiwiTWFkdG93biBNb250aGx5IiwiUmVwdWJsaWMgUmlkZXIiLCJBbm51YWwgKENpbmN5IFJlZCBCaWtlKSIsIkFubnVhbCAoT21haGEgQi1jeWNsZSkiLCJBbm51YWwgKE1hZGlzb24gQi1jeWNsZSkiLCJBbm51YWwgKERlbnZlciBCaWtlIFNoYXJpbmcpIiwiQW5udWFsIE1lbWJlcnNoaXAgKEZvcnQgV29ydGggQmlrZSBTaGFyaW5nKSIsIkhlYXJ0bGFuZCBQYXNzIChNb250aGx5IFBheSkiLCJSZXB1YmxpYyBSaWRlciAoQW5udWFsKSINCg0KKk90aGVyKg0KIkFsdW1pbnVtIEFjY2VzcyIsIkZvdW5kaW5nIE1lbWJlciAoQXVzdGluIEItY3ljbGUpIiwiRm91bmRpbmcgTWVtYmVyIg0KDQoqTWlzc2luZyoNCk5BLCAiUFJPSElCSVRFRCIsICJSRVNUUklDVEVEIg0KDQoNCg0KYGBge3J9DQpiaWtlY2xlYW4kTWVtYmVyc2hpcC5UeXBlW2lzLm5hKGJpa2VjbGVhbiRNZW1iZXJzaGlwLlR5cGUpXSA9ICJtaXNzaW5nIg0KYmlrZWNsZWFuJE1lbWJlcnNoaXAuVHlwZVt3aGljaChiaWtlY2xlYW4kTWVtYmVyc2hpcC5UeXBlICVpbiUgYygiUFJPSElCSVRFRCIsICJSRVNUUklDVEVEIikpXT0ibWlzc2luZyINCmJpa2VjbGVhbiRNZW1iZXJzaGlwLlR5cGVbd2hpY2goYmlrZWNsZWFuJE1lbWJlcnNoaXAuVHlwZSAlaW4lIGMoIjMtRGF5IEV4cGxvcmVyIiwiV2Vla2VuZGVyIiwiMy1EYXkgV2Vla2VuZGVyIiwiV2Vla2VuZGVyICgkMTUgcGx1cyB0YXgpIikpXT0iMyBEYXkiDQpiaWtlY2xlYW4kTWVtYmVyc2hpcC5UeXBlW3doaWNoKGJpa2VjbGVhbiRNZW1iZXJzaGlwLlR5cGUgJWluJSBjKCIkMSBQYXkgYnkgVHJpcCBGYWxsIFNwZWNpYWwiLCJTaW5nbGUgVHJpcCIsIlRyeSBCZWZvcmUgWW91IEJ1eSBTcGVjaWFsIiwiJDEgUGF5IGJ5IFRyaXAgV2ludGVyIFNwZWNpYWwiLCJSaWRlU2NvdXQgU2luZ2xlIFJpZGUiLCJTaW5nbGUgVHJpcCAiLCJTaW5nbGUgVHJpcCBSaWRlIiwgIlBheS1hcy15b3UtcmlkZSIsIlNpbmdsZSBUcmlwIChQYXktYXMteW91LXJpZGUpIiwiMjQtSG91ciBLaW9zayAoQXVzdGluIEItY3ljbGUpIiwgIjI0IEhvdXIgV2FsayBVcCBQYXNzIiwiV2FsayBVcCIpKV09IlNpbmdsZSBUcmlwIg0KYmlrZWNsZWFuJE1lbWJlcnNoaXAuVHlwZVt3aGljaChiaWtlY2xlYW4kTWVtYmVyc2hpcC5UeXBlICVpbiUgYygiMjQtSG91ci1PbmxpbmUgKEF1c3RpbiBCLWN5Y2xlKSIsIjI0LUhvdXIgTWVtYmVyc2hpcCAoQXVzdGluIEItY3ljbGUpIiwiRXhwbG9yZXIiLCJFeHBsb3JlciAoJDggcGx1cyB0YXgpIikpXT0iRGFpbHkiDQpiaWtlY2xlYW4kTWVtYmVyc2hpcC5UeXBlW3doaWNoKGJpa2VjbGVhbiRNZW1iZXJzaGlwLlR5cGUlaW4lYygiNy1EYXkiLCI3LURheSBNZW1iZXJzaGlwIChBdXN0aW4gQi1jeWNsZSkiLCI3LURheSBNZW1iZXJzaGlwIChBdXN0aW4gQi1jeWNsZSkiKSldPSJXZWVrbHkiDQpiaWtlY2xlYW4kTWVtYmVyc2hpcC5UeXBlW3doaWNoKGJpa2VjbGVhbiRNZW1iZXJzaGlwLlR5cGUlaW4lYygiTG9jYWwzMCAoJDExIHBsdXMgdGF4KSIsIkxvY2FsMzAiLCJMb2NhbDMxIikpXT0iTW9udGhseSINCmJpa2VjbGVhbiRNZW1iZXJzaGlwLlR5cGVbd2hpY2goYmlrZWNsZWFuJE1lbWJlcnNoaXAuVHlwZSVpbiVjKCJBbm51YWwgIiwiQW5udWFsIE1lbWJlcnNoaXAgIiwiQW5udWFsIFBhc3MiLCJBbm51YWwgUGx1cyIsIkxvY2FsMzY1IiwiTG9jYWwzNjUgKCQ4MCBwbHVzIHRheCkiLCJMb2NhbDM2NSBZb3V0aCAoYWdlIDEzLTE3IHJpZGVycyktIDEvMiIgLCJMb2NhbDM2NStHdWVzdCBQYXNzIiwiQW5udWFsIiwiQW5udWFsIE1lbWJlciIsIkFubnVhbCBNZW1iZXJzaGlwIiwiQW5udWFsIE1lbWJlcnNoaXAgKEF1c3RpbiBCLWN5Y2xlKSIsIkFubnVhbCBQYXNzICgzMCBtaW51dGUpIiwiQW5udWFsIFBsdXMgTWVtYmVyc2hpcCIsIkxvY2FsMzY1LSAxLzIgb2ZmIEFubml2ZXJzYXJ5IFNwZWNpYWwiLCJMb2NhbDM2NSBZb3V0aCAoYWdlIDEzLTE3IHJpZGVycykiLCAiTG9jYWwzNjUgWW91dGggd2l0aCBoZWxtZXQgKGFnZSAxMy0xNyByaWRlcnMpIiwiTG9jYWwzNjUrR3Vlc3QgUGFzcy0gMS8yIG9mZiBBbm5pdmVyc2FyeSBTcGVjaWFsIiwiTWVtYmVyc2hpcDogcGF5IG9uY2UgIG9uZS15ZWFyIGNvbW1pdG1lbnQiLCJMb2NhbDM2NSBZb3V0aCAoYWdlIDEzLTE3IHJpZGVycyktIDEvMiBvZmYgU3BlY2lhbCIpKV09IkFubnVhbCINCmJpa2VjbGVhbiRNZW1iZXJzaGlwLlR5cGVbd2hpY2goYmlrZWNsZWFuJE1lbWJlcnNoaXAuVHlwZSVpbiVjKCJIVCBSYW0gTWVtYmVyc2hpcCIsIlNlbWVzdGVyIE1lbWJlcnNoaXAiLCJVVCBTdHVkZW50IE1lbWJlcnNoaXAiLCJTZW1lc3RlciBNZW1iZXJzaGlwIChBdXN0aW4gQi1jeWNsZSkiLCJVLlQuIFN0dWRlbnQgTWVtYmVyc2hpcCIsIlUuVC4gU3R1ZGVudCBNZW1iZXJzaGlwIikpXT0iU3R1ZGVudCINCmJpa2VjbGVhbiRNZW1iZXJzaGlwLlR5cGVbd2hpY2goYmlrZWNsZWFuJE1lbWJlcnNoaXAuVHlwZSVpbiVjKCJBQ0wgMjAxOSBQYXNzIiwiQUNMIFdlZWtlbmQgUGFzcyBTcGVjaWFsIChBdXN0aW4gQi1jeWNsZSkiLCJGdW5GdW5GdW4gRmVzdCAzIERheSBQYXNzIikpXT0iRXZlbnQiDQpiaWtlY2xlYW4kTWVtYmVyc2hpcC5UeXBlW3doaWNoKGJpa2VjbGVhbiRNZW1iZXJzaGlwLlR5cGUlaW4lYygiQWx1bWludW0gQWNjZXNzIiwiRm91bmRpbmcgTWVtYmVyIChBdXN0aW4gQi1jeWNsZSkiLCJGb3VuZGluZyBNZW1iZXIiKSldPSJPdGhlciINCg0KYmlrZWNsZWFuJE1lbWJlcnNoaXAuVHlwZVt3aGljaChiaWtlY2xlYW4kTWVtYmVyc2hpcC5UeXBlJWluJWMoIkFubnVhbCAoQnJvd2FyZCBCLWN5Y2xlKSIsIkFubnVhbCAoRGVudmVyIEItY3ljbGUpIiwiQW5udWFsIChLYW5zYXMgQ2l0eSBCLWN5Y2xlKSIsIkFubnVhbCAoTmFzaHZpbGxlIEItY3ljbGUpIiwiQW5udWFsIChTYW4gQW50b25pbyBCLWN5Y2xlKSIsIkFubnVhbCBNZW1iZXIgKEhvdXN0b24gQi1jeWNsZSkiLCJBbm51YWwgTWVtYmVyc2hpcCAoQ2hhcmxvdHRlIEItY3ljbGUpIiwiQW5udWFsIE1lbWJlcnNoaXAgKEdSRUVOYmlrZSkiLCJEZW52ZXIgQi1jeWNsZSBGb3VuZGVyIiwiSGVhcnRsYW5kIFBhc3MgKEFubnVhbCBQYXkpIiwiTWFkdG93biBNb250aGx5IiwiUmVwdWJsaWMgUmlkZXIiLCJBbm51YWwgKENpbmN5IFJlZCBCaWtlKSIsIkFubnVhbCAoT21haGEgQi1jeWNsZSkiLCJBbm51YWwgKE1hZGlzb24gQi1jeWNsZSkiLCJBbm51YWwgKERlbnZlciBCaWtlIFNoYXJpbmcpIiwiQW5udWFsIE1lbWJlcnNoaXAgKEZvcnQgV29ydGggQmlrZSBTaGFyaW5nKSIsIkhlYXJ0bGFuZCBQYXNzIChNb250aGx5IFBheSkiLCJSZXB1YmxpYyBSaWRlciAoQW5udWFsKSIsICJBbm51YWwgTWVtYmVyc2hpcCAoSW5keSAtIFBhY2VycyBCaWtlc2hhcmUgKSIsICJBbm51YWwgKEJvdWxkZXIgQi1jeWNsZSkiKSldPSJTaGFyZSINCmBgYA0KDQpgYGB7cn0NCnNvcnQodW5pcXVlKGJpa2VjbGVhbiRNZW1iZXJzaGlwLlR5cGUpKQ0KYGBgDQpMb29raW5nIGdvb2QhIEkgbWlnaHQgdHJ5IGFuZCBwcmVkaWN0IG91ciBtaXNzaW5nIG1lbWJlcnNoaXAgdHlwZXMgaWYgSSBoYXZlIHRpbWUuDQoNCiMjIE1lcmdpbmcgb3VyIERhdGFzZXRzDQoNCmBgYHtyfQ0KbWVyZ2VkID0gbWVyZ2UoYmlrZWNsZWFuLHdlYXRoZXJjbGVhbixieS54ID0gIkNoZWNrb3V0LkRhdGUiLGJ5LnkgPSJEYXRlIikNCmBgYA0KDQpgYGB7cn0NCnNhdmVSRFMobWVyZ2VkLGZpbGUgPSAnbWVyZ2VkLnJkcycpDQpgYGANCk5vdyBJIGRvbid0IGhhdmUgdG8gcnVuIGV2ZXJ5dGhpbmcgYWJvdmUgdGhpcyBFVkVSWSB0aW1lIEkgbmVlZCB0byBzdGFydCBvdmVyLg0KDQpgYGB7cn0NCm1lcmdlZCA9IHJlYWRSRFMoIm1lcmdlZC5yZHMiKQ0KbWVyZ2VkJE1lbWJlcnNoaXAuVHlwZT1mYWN0b3IobWVyZ2VkJE1lbWJlcnNoaXAuVHlwZSkNCmBgYA0KDQoNCiMgRGF0YSB2aXN1YWxpemF0aW9uDQoNCg0KYGBge3J9DQpnZ3Bsb3QobWVyZ2VkKSsNCiAgZ2VvbV9wb2ludChhZXMoeCA9IENoZWNrb3V0LkRhdGUsIHk9cm91bmQoVHJpcC5EdXJhdGlvbi5NaW51dGVzLzYwKSkpKw0KICBnZW9tX2hsaW5lKHlpbnRlcmNlcHQ9MSxjb2xvciA9ICJyZWQiKQ0KYGBgDQoNClRyaXBzIGFyZSBleHBlY3RlZCB0byBiZSBhdCAxIGhvdXIgaW4gbGVuZ3RoLiBBbnkgbW9yZSB0aGFuIHRoYXQgYW5kIHRoZXJlIGlzIGEgZmluZSBhc3NvY2lhdGVkIHdpdGggZWFjaCBtaW51dGUgb3ZlciB5b3UgcmlkZS4gYXMgdGltZSBoYXMgZ29uZSBvbiwgbW9yZSBwZW9wbGUgYXJlbid0IGNoZWNraW5nIHRoZWlyIGJpa2VzIGluIG9uIHRpbWUuIA0KDQpJIHdvbmRlciB3aGF0J3MgdXAgd2l0aCB0aGUgd2VpcmQgZ2FwcyBpbiAyMDE2Lg0KDQpgYGB7cn0NCmdncGxvdChtZXJnZWRbd2hpY2goeWVhcihtZXJnZWQkQ2hlY2tvdXQuRGF0ZSk9PTIwMTYpLF0pKw0KICAgIGdlb21fcG9pbnQoYWVzKHggPSBDaGVja291dC5EYXRlLCB5PXJvdW5kKFRyaXAuRHVyYXRpb24uTWludXRlcy82MCkpKQ0KYGBgDQpgYGB7cn0NCmdncGxvdChtZXJnZWRbd2hpY2goeWVhcihtZXJnZWQkQ2hlY2tvdXQuRGF0ZSk9PTIwMTYgJiBtb250aChtZXJnZWQkQ2hlY2tvdXQuRGF0ZSk9PTQpLF0pKw0KICAgICAgZ2VvbV9wb2ludChhZXMoeCA9IENoZWNrb3V0LkRhdGUsIHk9cm91bmQoVHJpcC5EdXJhdGlvbi5NaW51dGVzLzYwKSkpDQpgYGANCg0KYGBge3J9DQptZXJnZWRbd2hpY2goeWVhcihtZXJnZWQkQ2hlY2tvdXQuRGF0ZSk9PTIwMTYgJiBtb250aChtZXJnZWQkQ2hlY2tvdXQuRGF0ZSk9PTQpLF0NCmBgYA0KR3JlYXQsIG5vIGRhdGEgZm9yIHRoYXQgbW9udGguDQoNCg0KYGBge3J9DQptZXJnZWRbd2hpY2goeWVhcihtZXJnZWQkQ2hlY2tvdXQuRGF0ZSk9PTIwMTYgJiBtb250aChtZXJnZWQkQ2hlY2tvdXQuRGF0ZSk9PTEyKSxdDQpgYGANClNhbWUgd2l0aCBEZWNlbWJlci4NCg0KYGBge3J9DQpnZ3Bsb3QobWVyZ2VkKSsNCiAgZ2VvbV9iYXIoYWVzKHg9ZmFjdG9yKG1vbnRoKENoZWNrb3V0LkRhdGUpKSksIGZpbGwgPSAiYmx1ZSIpKw0KICBmYWNldF93cmFwKH55ZWFyKENoZWNrb3V0LkRhdGUpKQ0KYGBgDQpXZSBjYW4gc2VlIHRoZXJlIGlzIGEgY3ljbGljYWwgbmF0dXJlIHRvIHRoZSBudW1iZXIgb2YgdHJpcHMgdGFrZW4gcGVyIG1vbnRoLiBJbnR1aXRpdmVseSwgdGhlcmUgYXJlIG1vcmUgcmlkZXJzIHdoZW4gdGhlIHdlYXRoZXIgaXMgbmljZS4NCmBgYHtyfQ0Kc3VtbWFyeShtZXJnZWQkQXZnVGVtcCkNCmBgYA0KDQpgYGB7cn0NCmdncGxvdChtZXJnZWQpKw0KICBnZW9tX2hpc3RvZ3JhbShhZXMoeD0gQXZnVGVtcCksIGJpbnMgPSA0NSwgZmlsbCA9ICJibHVlIikNCmBgYA0KDQpNb3N0IHBlb3BsZSByaWRlIGJldHdlZW4gYW5kIDEyIGFuZCAzMiBkZWdyZWVzIENlbHNpdXMNCg0KDQpgYGB7cn0NCm1lcmdlZCAlPiUgDQogIGdyb3VwX2J5KENoZWNrb3V0Lktpb3NrKSAlPiUNCiAgc3VtbWFyaXNlKERlcGFydGluZ19CaWtlcyA9IGxlbmd0aChDaGVja291dC5LaW9zaykpICU+JSBhcnJhbmdlKC4sZGVzYyhEZXBhcnRpbmdfQmlrZXMpKQ0KYGBgDQoNCg0KYGBge3J9DQptZXJnZWQgJT4lDQogIGdncGxvdCgpICsNCiAgZ2VvbV9iYXIoYWVzKHg9Q2hlY2tvdXQuS2lvc2spLCBmaWxsID0gInJlZCIpKw0KICB0aGVtZShheGlzLnRpdGxlLng9ZWxlbWVudF9ibGFuaygpLCBheGlzLnRleHQueD1lbGVtZW50X2JsYW5rKCksIGF4aXMudGlja3MueD1lbGVtZW50X2JsYW5rKCkpDQpgYGANCkJpa2VzIGxlYXZlIHRoZSBjYW1wdXMgU3BlZWR3YXkgYXQgYSB2ZXJ5IGhpZ2ggcmF0ZQ0KDQpgYGB7cn0NCm1lcmdlZCAlPiUNCiAgZ2dwbG90KCkgKw0KICBnZW9tX2JhcihhZXMoeD1SZXR1cm4uS2lvc2spLCBmaWxsID0gImJsdWUiKSsNCiAgdGhlbWUoYXhpcy50aXRsZS54PWVsZW1lbnRfYmxhbmsoKSwgYXhpcy50ZXh0Lng9ZWxlbWVudF9ibGFuaygpLCBheGlzLnRpY2tzLng9ZWxlbWVudF9ibGFuaygpKQ0KYGBgDQoNCmBgYHtyfQ0KbWVyZ2VkICU+JSANCiAgZ3JvdXBfYnkoUmV0dXJuLktpb3NrKSAlPiUNCiAgc3VtbWFyaXNlKERlcGFydGluZ19CaWtlcyA9IGxlbmd0aChSZXR1cm4uS2lvc2spKSAlPiUgYXJyYW5nZSguLGRlc2MoRGVwYXJ0aW5nX0Jpa2VzKSkNCmBgYA0KDQpFdmVuIG1vcmUgYXJlIHJldHVybmVkIHRoZXJlDQoNCg0KIyBEYWlseSBEaWZmZXJlbnRpYWwgUmVxdWlyaW5nIEh1bWFuIEludGVydmVudGlvbg0KDQpgYGB7cn0NCmNoZWNrb3V0ID0gbWVyZ2VkICU+JSBncm91cF9ieShDaGVja291dC5EYXRlLCBDaGVja291dC5LaW9zaykgJT4lIHRhbGx5KCkgJT4lIHNwcmVhZChDaGVja291dC5EYXRlLCBuKQ0KY2hlY2tvdXQgPSBjaGVja291dFstd2hpY2goY2hlY2tvdXQkQ2hlY2tvdXQuS2lvc2sgPT0gImVleW9yZS9zMjAxOCIpLF0NCnJldHVybiA9IG1lcmdlZCAlPiUgZ3JvdXBfYnkoQ2hlY2tvdXQuRGF0ZSwgUmV0dXJuLktpb3NrKSAlPiUgdGFsbHkoKSAlPiUgc3ByZWFkKENoZWNrb3V0LkRhdGUsIG4pDQpyZXR1cm4gPSByZXR1cm5bLXdoaWNoKCFyZXR1cm4kUmV0dXJuLktpb3NrICVpbiUgY2hlY2tvdXQkQ2hlY2tvdXQuS2lvc2spLF0NCmNoZWNrb3V0W2lzLm5hKGNoZWNrb3V0KV0gPSAwIA0KcmV0dXJuW2lzLm5hKHJldHVybildPSAwDQpgYGANCg0KYGBge3J9DQpkaWZmID0gZGF0YS5mcmFtZShyZXR1cm4kUmV0dXJuLktpb3NrLHJldHVyblssLTFdLWNoZWNrb3V0WywtMV0pDQpgYGANCg0KYGBge3J9DQpkaWZmDQpgYGANCg0KDQoNCmBgYHtyfQ0KZGFpbHlfZGlmZiA9IGRhdGEuZnJhbWUoY29sU3VtcyhhYnMoZGlmZlssLTFdKSkpDQpkYWlseV9kaWZmIDwtIHJvd25hbWVzX3RvX2NvbHVtbihkYWlseV9kaWZmLCAiRGF0ZSIpDQpkYWlseV9kaWZmJERhdGUgPSBnc3ViKCAiWCIsICIiLCBkYWlseV9kaWZmJERhdGUpDQpkYWlseV9kaWZmJERhdGUgPSBhcy5EYXRlKHN0cnB0aW1lKGRhaWx5X2RpZmYkRGF0ZSwgZm9ybWF0ID0gJyVZLiVtLiVkJykpDQpjb2xuYW1lcyhkYWlseV9kaWZmKSA9IGMoIkRhdGUiLCJEaWZmIikNCmBgYA0KDQpgYGB7cn0NCmRhaWx5X2RpZmYNCmBgYA0KDQoNCmBgYHtyfQ0KZ2dwbG90KGRhaWx5X2RpZmYpKw0KICBnZW9tX2JhcihhZXMoeD1EYXRlLCB5ID0gRGlmZiksIHN0YXQgPSAiaWRlbnRpdHkiKQ0KYGBgDQpgYGB7cn0NCmRhaWx5X2RpZmYgPSBtZXJnZShkYWlseV9kaWZmLHdlYXRoZXJjbGVhbixieS54ID0gIkRhdGUiLGJ5LnkgPSJEYXRlIikNCmRhaWx5X2RpZmYkbW9udGggPSBtb250aChkYWlseV9kaWZmJERhdGUpDQpgYGANCg0KYGBge3J9DQp4Z3JpZCA9IHNlcSgtMTAsNTAsLjAwMSkNCmdncGxvdChkYWlseV9kaWZmKSArDQogIGdlb21fcG9pbnQoYWVzKHggPSBBdmdUZW1wLCB5ID0gRGlmZiwgY29sb3IgPWZhY3Rvcihtb250aChEYXRlKSkpKQ0KYGBgDQpUaGlzIHNlZW1zIGxpa2Ugb25lIG9mIHRob3NlIHRoaW5ncyB3ZSB3b3VsZCB3YW50IHRvIHByZWRpY3Qgc28gdGhhdCB3ZSBjYW4ga25vdyBzdGFmZmluZyBsZXZlbHMuIExldCdzIHRyeSB0byBwcmVkaWN0IGl0IHdpdGggYSByYW5kb20gZm9yZXN0Lg0KDQojIyBSYW5kb20gRm9yZXN0DQoNCmBgYHtyfQ0KaGVhZChkYWlseV9kaWZmKQ0KYGBgDQoNCg0KYGBge3J9DQpzZXQuc2VlZCgxMjMpDQp0cmFpbiA9IHNhbXBsZSAoMTpucm93KGRhaWx5X2RpZmYpLCBucm93KGRhaWx5X2RpZmYpLzIpDQpgYGANCg0KDQpgYGB7cn0NCnJmLmRkPSByYW5kb21Gb3Jlc3QoRGlmZiB+IERhdGUgKyBBdmdUZW1wLGRhdGE9ZGFpbHlfZGlmZiwgc3Vic2V0PXRyYWluKQ0KeWhhdC5yZiA9IHByZWRpY3QocmYuZGQgLG5ld2RhdGE9ZGFpbHlfZGlmZlstIHRyYWluICxdKQ0KbWVhbigoeWhhdC5yZi1kYWlseV9kaWZmWy10cmFpbiwgIkRpZmYiXSleMikNCmBgYA0KDQpgYGB7cn0NCmdncGxvdCgpKw0KICBnZW9tX3BvaW50KGFlcyh4PWRhaWx5X2RpZmYkRGlmZlstdHJhaW5dLHkgPSB5aGF0LnJmKSkrDQogIGdlb21fYWJsaW5lKGNvbG9yID0gInJlZCIpDQpgYGANCg0KDQoNCg0KDQpgYGB7cn0NCnN1bW1hcnkoZGFpbHlfZGlmZikNCmBgYA0KTm90IHRlcnJpYmxlLCBidXQgdGhlcmUgYXJlIHNvbWUgYXJlYXMgd2hlcmUgdGhlIG1vZGVsIGdldHMgaXQgcHJldHR5IHdyb25nDQoNCkxldCdzIHRyeSBib29zdGluZw0KDQpgYGB7cn0NCnNldC5zZWVkKDEyKQ0KYm9vc3QuZGQ9Z2JtKERpZmZ+QXZnVGVtcCttb250aChEYXRlKSt5ZWFyKERhdGUpK2RheShEYXRlKSxkYXRhPWRhaWx5X2RpZmZbdHJhaW4gLF0sIGRpc3RyaWJ1dGlvbj0iZ2F1c3NpYW4iLG4udHJlZXM9NTAwMCwgc2hyaW5rYWdlID0gLjAxLGludGVyYWN0aW9uLmRlcHRoID0gMykNCmBgYA0KDQpgYGB7cn0NCmJlc3QuaXRlciA8LSBnYm0ucGVyZihib29zdC5kZCwgbWV0aG9kID0gIk9PQiIsIHBsb3QgPSBGQUxTRSkNCnloYXQuYm9vc3Q9cHJlZGljdCAoYm9vc3QuZGQgLG5ld2RhdGEgPWRhaWx5X2RpZmZbLXRyYWluICxdLCBuLnRyZWVzPWJlc3QuaXRlcikNCm1lYW4oKHloYXQuYm9vc3QtZGFpbHlfZGlmZlstdHJhaW4sICJEaWZmIl0pXjIpDQpgYGANCmBgYHtyfQ0KZ2dwbG90KCkrDQogIGdlb21fcG9pbnQoYWVzKHg9ZGFpbHlfZGlmZiREaWZmWy10cmFpbl0seSA9IHloYXQuYm9vc3QpKSsNCiAgZ2VvbV9hYmxpbmUoY29sb3IgPSAicmVkIikNCmBgYA0KDQoNCmBgYHtyfQ0KZGFpbHlfZGlmZltkYWlseV9kaWZmJERpZmY+MzAwLCAnRGF0ZSddDQpgYGANCg0KIyMgQU5OIFRyeQ0KDQpgYGB7cn0NCmxpYnJhcnkobmV1cmFsbmV0KQ0KbGlicmFyeShOZXVyYWxOZXRUb29scykNCmBgYA0KDQpgYGB7cn0NCmRhaWx5X2RpZmYkeWVhciA9IHllYXIoZGFpbHlfZGlmZiREYXRlKQ0KZGFpbHlfZGlmZiRkYXkgPSBkYXkoZGFpbHlfZGlmZiREYXRlKQ0KZGQuc2NhbGVkIDwtIGFzLmRhdGEuZnJhbWUoc2NhbGUoZGFpbHlfZGlmZlssLTFdKSkNCm1pbi5kaWZmIDwtIG1pbihkYWlseV9kaWZmJERpZmYpDQptYXguZGlmZiA8LSBtYXgoZGFpbHlfZGlmZiREaWZmKQ0KYGBgDQoNCmBgYHtyfQ0KZGQuc2NhbGVkDQpgYGANCg0KYGBge3J9DQpkZC5zY2FsZWQkRGlmZiA8LSBzY2FsZShkYWlseV9kaWZmJERpZmYsIGNlbnRlciA9IG1pbi5kaWZmLCBzY2FsZSA9IG1heC5kaWZmIC0gbWluLmRpZmYpDQpgYGANCg0KYGBge3J9DQpkZC5zcGxpdCA8LSBzYW1wbGUoZGltKGRhaWx5X2RpZmYpWzFdLGRpbShkYWlseV9kaWZmKVsxXS8yICkNCiMgVHJhaW4tdGVzdCBzcGxpdA0KZGQudHJhaW4uc2NhbGVkIDwtIGRkLnNjYWxlZFtkZC5zcGxpdCwgXQ0KZGQudGVzdC5zY2FsZWQgPC0gZGQuc2NhbGVkWy1kZC5zcGxpdCwgXQ0KYGBgDQoNCmBgYHtyfQ0KZ2VuZXJhdGUuZnVsbC5mbWxhPC0gZnVuY3Rpb24oZGYsIHJlc3BvbnNlKXsNCiAgbmFtZXMoZGYpWyEobmFtZXMoZGYpID09IHJlc3BvbnNlKV0lPiUNCiAgICBwYXN0ZSguLGNvbGxhcHNlID0gIisiKSU+JQ0KICAgICBwYXN0ZShyZXNwb25zZSwgIn4iLCAuKSU+JQ0KICAgIGZvcm11bGEoLikNCn0NCmRkLm5uLmZtbGEgPC0gZ2VuZXJhdGUuZnVsbC5mbWxhKGRkLnRyYWluLnNjYWxlZCwgIkRpZmYiKQ0KZGQubm4uNS4zIDwtIG5ldXJhbG5ldChkZC5ubi5mbWxhDQogICAgICAgICAgICAgICAgICAgICAgICAgICAsIGRhdGE9ZGQudHJhaW4uc2NhbGVkDQogICAgICAgICAgICAgICAgICAgICAgICAgICAsIGhpZGRlbj1jKDUsMykNCiAgICAgICAgICAgICAgICAgICAgICAgICAgICwgbGluZWFyLm91dHB1dD1UUlVFKQ0KZGQubm4uOCA8LSBuZXVyYWxuZXQoZGQubm4uZm1sYQ0KICAgICAgICAgICAgICAgICAgICAgICAgICAgLCBkYXRhPWRkLnRyYWluLnNjYWxlZA0KICAgICAgICAgICAgICAgICAgICAgICAgICAgLCBoaWRkZW49OA0KICAgICAgICAgICAgICAgICAgICAgICAgICAgLCBsaW5lYXIub3V0cHV0PVRSVUUpDQpyZi5kZD0gcmFuZG9tRm9yZXN0KGRkLm5uLmZtbGEsZGF0YT1kZC50cmFpbi5zY2FsZWQpDQoNCmBgYA0KDQpgYGB7cn0NCmZpdG5lc3MubWVhc3VyZXMgPC0gZnVuY3Rpb24odGVzdCwgbW9kZWwsIHJlc3BvbnNlKXsNCiAgZGF0YS5mcmFtZSh5ID0gdGVzdFssIHJlc3BvbnNlXSwgeWhhdCA9IHByZWRpY3QobW9kZWwsIG5ld2RhdGEgPSB0ZXN0KSklPiUNCiAgICBzdW1tYXJpemUoTVNFID0gc3VtKCh5LXloYXQpXjIpL24oKSwgTUFEID0gc3VtKGFicyh5IC0geWhhdCkpL24oKSklPiUNCiAgICBtdXRhdGUoUk1TRSA9IHNxcnQoTVNFKSkNCn0NCmBgYA0KDQpgYGB7cn0NCmZpdG5lc3MubWVhc3VyZXMoZGQudGVzdC5zY2FsZWQsIGRkLm5uLjUuMywgIkRpZmYiKQ0KZml0bmVzcy5tZWFzdXJlcyhkZC50ZXN0LnNjYWxlZCwgZGQubm4uOCwgIkRpZmYiKQ0KZml0bmVzcy5tZWFzdXJlcyhkZC50ZXN0LnNjYWxlZCwgcmYuZGQsICJEaWZmIikNCmBgYA0KDQpgYGB7cn0NCm1vZGVscyA9IGxpc3QoKQ0KDQpmb3IgKGkgaW4gMzoxMil7DQogIG5uIDwtIG5ldXJhbG5ldChkZC5ubi5mbWxhDQogICAgICAgICAgICAgICAgICAgICAgICAgICAsIGRhdGE9ZGQudHJhaW4uc2NhbGVkDQogICAgICAgICAgICAgICAgICAgICAgICAgICAsIGhpZGRlbj0gaSANCiAgICAgICAgICAgICAgICAgICAgICAgICAgICwgbGluZWFyLm91dHB1dD1UUlVFKQ0KICBtb2RlbHNbW2ldXSA8LSBubg0KfQ0KICANCmBgYA0KDQpgYGB7cn0NCm1zZSA9IGxpc3QoKQ0KZm9yIChpIGluIDM6MTIpIHsNCiBtc2VbaV0gPC0gKGZpdG5lc3MubWVhc3VyZXMoZGQudGVzdC5zY2FsZWQsIG1vZGVsc1tbaV1dLCAiRGlmZiIpWzFdICogKChtYXguZGlmZi1taW4uZGlmZikqKjIpKQ0KfQ0KDQptc2VbMV0gPC0gZml0bmVzcy5tZWFzdXJlcyhkZC50ZXN0LnNjYWxlZCwgZGQubm4uNS4zLCAiRGlmZiIpWzFdICogKChtYXguZGlmZi1taW4uZGlmZikqKjIpDQptc2VbMl0gPC0gZml0bmVzcy5tZWFzdXJlcyhkZC50ZXN0LnNjYWxlZCwgcmYuZGQsICJEaWZmIilbMV0gKiAoKG1heC5kaWZmLW1pbi5kaWZmKSoqMikNCg0KbXNlDQoNCg0KYGBgDQoNCg0KYGBge3J9DQpOZXVyYWxOZXRUb29sczo6Z2Fyc29uKG1vZGVsc1tbMTBdXSkNCmBgYA0KYGBge3J9DQpOZXVyYWxOZXRUb29sczo6cGxvdG5ldChtb2RlbHNbWzEwXV0pDQoNCmBgYA0KDQojIFRyaXAgZHVyYXRpb24NCg0KYGBge3J9DQpnZ3Bsb3QobWVyZ2VkKSsNCiAgZ2VvbV9wb2ludChhZXMoeD1DaGVja291dC5LaW9zaywgeSA9IFRyaXAuRHVyYXRpb24uTWludXRlcyApKSsNCiAgdGhlbWUoYXhpcy50aXRsZS54PWVsZW1lbnRfYmxhbmsoKSwgYXhpcy50ZXh0Lng9ZWxlbWVudF9ibGFuaygpLCBheGlzLnRpY2tzLng9ZWxlbWVudF9ibGFuaygpKQ0KYGBgDQpTb21lIHN0YXRpb25zIGRvbid0IGhhdmUgbG9uZyB0cmlwcyBhc3NvY2lhdGVkIHdpdGggdGhlbSBhdCBhbGwsIHdoaWxlIG90aGVycyBoYXZlIFRPTlMgb2YgbG9uZyB0cmlwcyBhc3NvY2lhdGVkIHdpdGggdGhlbS4NCg0KDQpgYGB7cn0NCmdncGxvdChtZXJnZWQpKw0KICBnZW9tX3BvaW50KGFlcyh5PU1lbWJlcnNoaXAuVHlwZSwgeCA9IFRyaXAuRHVyYXRpb24uTWludXRlcyApKSsNCiAgZ2VvbV92bGluZSh4aW50ZXJjZXB0ID0gNjAsIGNvbG9yID0gInJlZCIpDQpgYGANCg0KU2luZ2xlIHRyaXBzIHJ1biBsb25nIHRoZSBtb3N0IG9mdGVuLCBidXQgdGhlcmUgYSBsb3Qgb2YgbGF0ZSB0cmlwcyBwZXJpb2QuDQoNCmBgYHtyfQ0KbWVyZ2VkJGxhdGUgPSBpZmVsc2UobWVyZ2VkJFRyaXAuRHVyYXRpb24uTWludXRlcyA+IDYwLDEgLDApDQpgYGANCg0KYGBge3J9DQpnZ3Bsb3QobWVyZ2VkKSsNCiAgZ2VvbV9iYXIoYWVzKHkgPSBNZW1iZXJzaGlwLlR5cGUsZmlsbCA9IGZhY3RvcihsYXRlKSkpDQpgYGANCg0KYGBge3J9DQpnZ3Bsb3QobWVyZ2VkKSsNCiAgZ2VvbV9iYXIoYWVzKHggPSBDaGVja291dC5LaW9zayxmaWxsID0gZmFjdG9yKGxhdGUpKSkrDQogIHRoZW1lKGF4aXMudGl0bGUueD1lbGVtZW50X2JsYW5rKCksIGF4aXMudGV4dC54PWVsZW1lbnRfYmxhbmsoKSwgYXhpcy50aWNrcy54PWVsZW1lbnRfYmxhbmsoKSkNCmBgYA0KYGBge3J9DQpoZWFkKG1lcmdlZCkNCmBgYA0KDQpgYGB7cn0NCnRlbXBfbWVyZ2VkID0gbWVyZ2VkI1t5ZWFyKG1lcmdlZCRDaGVja291dC5EYXRlKT4yMDE4LF0NCnRlbXBfbWVyZ2VkJENoZWNrb3V0Lktpb3NrID0gZmFjdG9yKHRlbXBfbWVyZ2VkJENoZWNrb3V0Lktpb3NrKQ0KdGVtcF9tZXJnZWQkaG91ciA9IGhvdXIodGVtcF9tZXJnZWQkQ2hlY2tvdXQuVGltZSkNCnRlbXBfbWVyZ2VkJE1lbWJlcnNoaXAuVHlwZSA9IGZhY3Rvcih0ZW1wX21lcmdlZCRNZW1iZXJzaGlwLlR5cGUpDQpgYGANCg0KDQpgYGB7cn0NCnNldC5zZWVkKDEyMykNCnRyYWluID0gc2FtcGxlICgxOm5yb3codGVtcF9tZXJnZWQpLCBucm93KHRlbXBfbWVyZ2VkKS8yKQ0KYGBgDQoNCmBgYHtyfQ0Kc2V0LnNlZWQoMTIpDQpib29zdC5tZXJnZWQ9Z2JtKFRyaXAuRHVyYXRpb24uTWludXRlc35NZW1iZXJzaGlwLlR5cGUraG91ciArIENoZWNrb3V0Lktpb3NrK0F2Z1RlbXAsZGF0YT10ZW1wX21lcmdlZFt0cmFpbiAsXSwgZGlzdHJpYnV0aW9uPSJnYXVzc2lhbiIsbi50cmVlcz01MDAsIHNocmlua2FnZSA9IC4xKQ0KYGBgDQoNCmBgYHtyfQ0Kc3VtbWFyeShib29zdC5tZXJnZWQpDQpgYGANCg0KDQpgYGB7cn0NCmdibS5wZXJmKGJvb3N0Lm1lcmdlZCwgbWV0aG9kID0gIk9PQiIpDQpgYGANCg0KYGBge3J9DQpwcmVkID0gcHJlZGljdC5nYm0ob2JqZWN0ID0gYm9vc3QubWVyZ2VkLG5ld2RhdGEgPSB0ZW1wX21lcmdlZFstdHJhaW4sXSwgbi50cmVlcyA9IDM0KQ0KYGBgDQoNCg0KYGBge3J9DQptZWFuKChwcmVkIC0gdGVtcF9tZXJnZWQkVHJpcC5EdXJhdGlvbi5NaW51dGVzWy10cmFpbl0pXjIpDQpgYGANCg0KDQpgYGB7cn0NCmdncGxvdCgpKw0KICBnZW9tX3BvaW50KGFlcyh4PXRlbXBfbWVyZ2VkJFRyaXAuRHVyYXRpb24uTWludXRlc1stdHJhaW5dLCB5ID0gcHJlZCkpKw0KICBnZW9tX2FibGluZSgpDQpgYGANCmBgYHtyfQ0KaGVhZCh0ZW1wX21lcmdlZCkNCmBgYA0KDQoNCmBgYHtyfQ0KYm9vc3QubWVyZ2VkPWdibShsYXRlfk1lbWJlcnNoaXAuVHlwZStob3VyICsgQ2hlY2tvdXQuS2lvc2srQXZnVGVtcCxkYXRhPXRlbXBfbWVyZ2VkW3RyYWluICxdLCBkaXN0cmlidXRpb249ImJlcm5vdWxsaSIsbi50cmVlcz01MDAsIHNocmlua2FnZSA9IC4xKQ0KYGBgDQoNCmBgYHtyfQ0Kc3VtbWFyeShib29zdC5tZXJnZWQpDQpgYGANCg0KDQpgYGB7cn0NCnByb2IgPSBwcmVkaWN0KGJvb3N0Lm1lcmdlZCwgbmV3ZGF0YSA9IHRlbXBfbWVyZ2VkWy10cmFpbiAsXSwgdHlwZSA9ICJyZXNwb25zZSIpDQp5aGF0ID0gaWZlbHNlKHByb2IgPi41LDEsMCkNCnN1bSh5aGF0KQ0KYGBgDQoNCmBgYHtyfQ0KaGlzdChwcm9iKQ0KYGBgDQoNCg0KYGBge3J9DQp5aGF0ID0gaWZlbHNlKHByb2IgPi41LDEsMCkNCmNtID0gdCh0YWJsZSh5aGF0LCB0ZW1wX21lcmdlZCRsYXRlWy10cmFpbl0pKQ0KY20NCmBgYA0KYGBge3J9DQpzdW0oZGlhZyhjbSkpL3N1bShjbSkgI0FjY3VyYWN5DQpjbVsxLDFdL3N1bShjbVsxLCBjKDEsMildKSAjQ29ycmVjdCByYXRlIG9mIG5lZ2F0aXZlIHByZWRpY3RlZCB2YWx1ZXMNCmNtWzIsMl0vc3VtKGNtWzIsIGMoMSwyKV0pICNDb3JyZWN0IHJhdGUgb2YgcG9zaXRpdmUgcHJlZGljdGVkIHZhbHVlDQpgYGANCmBgYHtyfQ0KeWhhdCA9IGlmZWxzZShwcm9iID4uMTUsMSwwKQ0KY20gPSB0KHRhYmxlKHloYXQsIHRlbXBfbWVyZ2VkJGxhdGVbLXRyYWluXSkpDQpjbQ0KYGBgDQoNCmBgYHtyfQ0Kc3VtKGRpYWcoY20pKS9zdW0oY20pICNBY2N1cmFjeQ0KY21bMSwxXS9zdW0oY21bMSwgYygxLDIpXSkgI0NvcnJlY3QgcmF0ZSBvZiBuZWdhdGl2ZSBwcmVkaWN0ZWQgdmFsdWVzDQpjbVsyLDJdL3N1bShjbVsyLCBjKDEsMildKSAjQ29ycmVjdCByYXRlIG9mIHBvc2l0aXZlIHByZWRpY3RlZCB2YWx1ZQ0KDQpgYGANCg0KYGBge3J9DQoNCmBgYA0KDQoNCg0KDQoNCg==
]]>Titanic Trees2021-07-01T00:00:00+00:002021-07-01T00:00:00+00:00https://www.ndled.us/stats/2021/07/01/Titanic-Trees Titanic Trees

Work through the kaggle Titanic competition found here with bagging, random forest, and GBM boosting.

Libraries I might Use

library(tidyverse)
library(class)
library(ISLR)
library(tidyverse)
library(randomForest)
library(gbm)
library(MASS)
library(rpart)
library(caTools)

Loading in the Data

train_data = read.csv("train.csv") # Train data Is really my sample overall
test_data = read.csv("test.csv") # New predictions will be performed on this data set

Encoding Factors and forcing NA for char columns

train_data[train_data==""] <- NA
train_data$Sex=factor(train_data$Sex, levels=c("male","female") ,labels = c(0,1))
train_data$Pclass=factor(train_data$Pclass, levels = c(1,2,3), labels = c(0,1,2))
train_data$Embarked=factor(train_data$Embarked, levels = c("C","Q","S"), labels = c(0,1,2))
train_data$Survived=factor(train_data$Survived)
train_data

Exploring the data

train_data
summary(train_data)
  PassengerId    Survived Pclass      Name           Sex          Age            SibSp           Parch           Ticket               Fare
 Min.   :  1.0   0:549    0:216   Length:891         0:577   Min.   : 0.42   Min.   :0.000   Min.   :0.0000   Length:891         Min.   :  0.00
 1st Qu.:223.5   1:342    1:184   Class :character   1:314   1st Qu.:20.12   1st Qu.:0.000   1st Qu.:0.0000   Class :character   1st Qu.:  7.91
 Median :446.0            2:491   Mode  :character           Median :28.00   Median :0.000   Median :0.0000   Mode  :character   Median : 14.45
 Mean   :446.0                                               Mean   :29.70   Mean   :0.523   Mean   :0.3816                      Mean   : 32.20
 3rd Qu.:668.5                                               3rd Qu.:38.00   3rd Qu.:1.000   3rd Qu.:0.0000                      3rd Qu.: 31.00
 Max.   :891.0                                               Max.   :80.00   Max.   :8.000   Max.   :6.0000                      Max.   :512.33
                                                             NA's   :177
    Cabin           Embarked
 Length:891         0   :168
 Class :character   1   : 77
 Mode  :character   2   :644
                    NA's:  2

  1. I’m predicting Survived

  2. Intuitively, I’d expect Pclass to be a significant predictor

  3. Likewise, don’t women and children always go first? So age and sex should be valuable predictors.

  4. SibSp represents the number of siblings/spouses aboard. Maybe important? If there are people with you they might help you escape, but you might also stay behind for them.

  5. Parch is the number of parents or children abboard. If you are young I’d expect higher number of parents increases your chance, while if you are older the number of children might cause you to hold back trying to help them.

  6. Information in fare is probably contained in class

  7. Cabin/Ticket seem unlikely to provide much meaningful information

  8. embarked is the port of embarkation. Unlikely to help much, but I’m not that confident about it.

All told our big factors are pclass, age, sex, sibsp, parch. Maybe embarked.

ggplot(train_data)+
  geom_violin(aes(x=Survived, y = Age, fill = Survived))

Right away we are reminded of 177 missing age values seen inthe summary.

We can also see that the didnt survive group has has a heavier weight around the age of 25.

ggplot(train_data[which(is.na(train_data$Age)),])+
  geom_bar(aes(x=Survived, fill = Survived))

Most of our missing values died

train_data[which(is.na(train_data$Age)),]
ggplot(train_data)+
  geom_bar(aes(x=Pclass, fill = Survived))

Ticket class breakdown is as you would expect.

ggplot(train_data)+
  geom_bar(aes(x=Embarked, fill = Survived))

There is more infromation that you would expect here. the final port of embarkation (southhampton) had the most people, but it also has the worst percentage of survival.

ggplot(train_data)+
  geom_bar(aes(x=SibSp, fill = Survived))

Most people had 0 spouses or siblings aboard, the better percentage at 1 could be attributed directly to spouse, but that doesn’t hold up for the better percentage at 2

ggplot(train_data)+
  geom_bar(aes(x=Parch, fill = Survived))

Increased survival at 1, 2, and 3. 1 and 2 are most likely being weighted by parents. 3 is interesting.

ggplot(train_data)+
  geom_bar(aes(x=Sex, fill = Survived))

Women survived at a MUCH higher rate.

train_data$agegroup = ifelse(train_data$Age < 16, 0, ifelse(train_data$Age < 50, 1, 2))
ggplot(train_data)+
 geom_bar(aes(x=agegroup, fill = Survived))

Children survive, those > 50 hardly do.

Dealing with Missing Values

Now that we have explored the data, lets deal with the missing values in embarked and age. We will be using survival, pclass, sex, age, sibsp, parch, and embarked to predict the others

clean_data = train_data[,c(2,3,5,6,7,8, 12)]
clean_data

Embarked

clean_data_embarked = clean_data[-which(is.na(train_data$Embarked)),]
clean_data_embarked

Test/Train Split

set.seed(1234)
split = sample.split(clean_data_embarked$Survived, SplitRatio = 0.8)
train = subset(clean_data_embarked, split == TRUE)
test = subset(clean_data_embarked, split == FALSE)

Model

set.seed(1234)
rf.Embarked = randomForest(Embarked~Survived + Pclass+Sex+SibSp+Parch, data = clean_data_embarked,importance =TRUE, mtry = 3)
importance(rf.Embarked)
                  0         1          2 MeanDecreaseAccuracy MeanDecreaseGini
Survived  0.1761412 23.926388 -0.7525674             10.47326         9.088543
Pclass   29.7102029 20.917772 17.0280234             33.91091        28.531706
Sex       1.1353457 25.138247  3.6891944             14.49255         9.606021
SibSp     5.0916546  3.144096  9.8194733             12.15916        18.989624
Parch     4.9348200 19.201793 16.3263343             21.33507        18.814807
yhat.Embarked = predict(rf.Embarked,newdata=test, type="response")
confusion_matrix = table(test$Embarked,yhat.Embarked)
confusion_matrix
   yhat.Embarked
      0   1   2
  0  15   0  23
  1   0   7   9
  2   6   1 117
124/(121+16+30+2+3)
[1] 0.7209302

Not great predictive power, but basically we only are replacing two values. (with 2 most likely) I could do more here by looking at other predictors that ARE probably predictive of location like fare and ticket, but for the sake of time I’m just going to leave it at embarkation = 2

train_data$Embarked[which(is.na(train_data$Embarked))] = 2
clean_data$Embarked[which(is.na(clean_data$Embarked))] = 2

Age

clean_data_age = clean_data[-which(is.na(train_data$Age)),]
clean_data_age = clean_data_age[,-1] #Can't use survived here because OG test set doesn't tell me survived.
clean_data_age

Test/Train Split

set.seed(1234)
split = sample.split(clean_data_age$Age, SplitRatio = 0.8)
train = subset(clean_data_age, split == TRUE)
test = subset(clean_data_age, split == FALSE)

Model

set.seed(1234)
rf.Age = randomForest(Age~., data = clean_data_age,importance =TRUE, mtry = 4)
importance(rf.Age)
           %IncMSE IncNodePurity
Pclass   87.248524     21086.175
Sex      16.198176      5410.003
SibSp    34.869585     15898.640
Parch    53.452846     21110.849
Embarked  9.446469      5809.567
yhat.Age = predict(rf.Age,newdata=test)
mean((yhat.Age-test$Age)^2)
[1] 110.6331

ooooph that is a a not great mean squared error, but lets keep rolling with it for now.

clean_data$Age[which(is.na(clean_data$Age))] = predict(rf.Age, newdata = clean_data[which(is.na(clean_data$Age)),])
train_data$Age[which(is.na(train_data$Age))] = predict(rf.Age, newdata = train_data[which(is.na(train_data$Age)),])

Modedl Building

clean_data
set.seed(1234)
split = sample.split(clean_data$Survived, SplitRatio = 0.8)
train = subset(clean_data, split == TRUE)
test = subset(clean_data, split == FALSE)
rf.Survived = randomForest(Survived~., data = train,importance =TRUE)
yhat.Survived = predict(rf.Survived,newdata=test, type="response")
confusion_matrix = table(test$Survived,yhat.Survived)
confusion_matrix
   yhat.Survived
     0  1
  0 92 18
  1 20 48
140/178
[1] 0.7865169

not bad, but how does it compare to gender?

yhat.gender = ifelse(test$Sex == 1, 1, 0)
confusion_matrix = table(test$Survived,yhat.gender)
confusion_matrix
   yhat.gender
     0  1
  0 89 21
  1 21 47
136/178
[1] 0.7640449

Better, but not THAT much better. Let’s go ahead and clean up the test data and submit

Test Data Cleanup

test_data
test_data
test_data$Sex=factor(test_data$Sex, levels=c("male","female") ,labels = c(0,1))
test_data$Pclass=factor(test_data$Pclass, levels = c(1,2,3), labels = c(0,1,2))
test_data$Embarked=factor(test_data$Embarked, levels = c("C","Q","S"), labels = c(0,1,2))
test_data_clean = test_data[,c(2,4,5,6,7,11)]
test_data_clean
summary(test_data_clean)
 Pclass  Sex          Age            SibSp            Parch        Embarked
 0:107   0:266   Min.   : 0.17   Min.   :0.0000   Min.   :0.0000   0:102
 1: 93   1:152   1st Qu.:21.00   1st Qu.:0.0000   1st Qu.:0.0000   1: 46
 2:218           Median :27.00   Median :0.0000   Median :0.0000   2:270
                 Mean   :30.27   Mean   :0.4474   Mean   :0.3923
                 3rd Qu.:39.00   3rd Qu.:1.0000   3rd Qu.:0.0000
                 Max.   :76.00   Max.   :8.0000   Max.   :9.0000
                 NA's   :86

Only missing values in Age

test_data_clean$Age[which(is.na(test_data_clean$Age))]=predict(rf.Age,test_data_clean[which(is.na(test_data_clean$Age)),])
test_data_clean
Rfguess = data.frame(test_data$PassengerId, predict(rf.Survived,test_data_clean))
colnames(Rfguess) <- c("PassengerId","Survived")
Rfguess
write.csv(Rfguess, "rfguess.csv",row.names = FALSE)

Final score: 0.77751, not great but I’m in the top quarter and improved over the gender guesses at least!

bagged.Survived = randomForest(Survived~., data = train,importance =TRUE, mtry = 6)
yhat.Survived = predict(bagged.Survived,newdata=test, type="response")
confusion_matrix = table(test$Survived,yhat.Survived)
confusion_matrix
   yhat.Survived
     0  1
  0 87 23
  1 19 49
110/188
[1] 0.5851064

a lot worse

Baggedguess = data.frame(test_data$PassengerId, predict(bagged.Survived,test_data_clean))
colnames(Baggedguess) <- c("PassengerId","Survived")
write.csv(Baggedguess, "rfguess.csv",row.names = FALSE)
boost.Survived = gbm(as.character(Survived)~., data = train, distribution="bernoulli", n.tree = 5000)
best.iter <- gbm.perf(boost.Survived, method = "OOB", plot = FALSE)
OOB generally underestimates the optimal number of iterations although predictive performance is reasonably competitive. Using cv_folds>1 when calling gbm usually results in improved predictive performance.
best.iter
[1] 92
attr(,"smoother")
Call:
loess(formula = object$oobag.improve ~ x, enp.target = min(max(4,
    length(x)/10), 50))

Number of Observations: 5000
Equivalent Number of Parameters: 39.99
Residual Standard Error: 0.000677 
prob = predict(boost.Survived, newdata=test, best.iter,type="response")
yhat.Survived = ifelse(prob>.5, 1, 0)
confusion_matrix = table(test$Survived,yhat.Survived)
confusion_matrix
   yhat.Survived
     0  1
  0 92 18
  1 16 52
140/178
[1] 0.7865169

Same as RF

boostedguess = data.frame(test_data$PassengerId, predict(boost.Survived,test_data_clean))
Using 5000 trees...
colnames(boostedguess) <- c("PassengerId","Survived")
write.csv(boostedguess, "boguess.csv",row.names = FALSE)
LS0tDQp0aXRsZTogIlRpdGFuaWMgVHJlZXMiDQpvdXRwdXQ6IGh0bWxfbm90ZWJvb2sNCi0tLQ0KDQpXb3JrIHRocm91Z2ggdGhlIGthZ2dsZSBUaXRhbmljIGNvbXBldGl0aW9uIGZvdW5kIFtoZXJlXShodHRwczovL3d3dy5rYWdnbGUuY29tL2MvdGl0YW5pYykgd2l0aCBiYWdnaW5nLCByYW5kb20gZm9yZXN0LCBhbmQgR0JNIGJvb3N0aW5nLg0KDQojIyBMaWJyYXJpZXMgSSBtaWdodCBVc2UNCg0KYGBge3J9DQpsaWJyYXJ5KHRpZHl2ZXJzZSkNCmxpYnJhcnkoY2xhc3MpDQpsaWJyYXJ5KElTTFIpDQpsaWJyYXJ5KHRpZHl2ZXJzZSkNCmxpYnJhcnkocmFuZG9tRm9yZXN0KQ0KbGlicmFyeShnYm0pDQpsaWJyYXJ5KE1BU1MpDQpsaWJyYXJ5KHJwYXJ0KQ0KbGlicmFyeShjYVRvb2xzKQ0KYGBgDQoNCg0KDQojIyBMb2FkaW5nIGluIHRoZSBEYXRhDQoNCmBgYHtyfQ0KdHJhaW5fZGF0YSA9IHJlYWQuY3N2KCJ0cmFpbi5jc3YiKSAjIFRyYWluIGRhdGEgSXMgcmVhbGx5IG15IHNhbXBsZSBvdmVyYWxsDQp0ZXN0X2RhdGEgPSByZWFkLmNzdigidGVzdC5jc3YiKSAjIE5ldyBwcmVkaWN0aW9ucyB3aWxsIGJlIHBlcmZvcm1lZCBvbiB0aGlzIGRhdGEgc2V0DQpgYGANCg0KDQojIyBFbmNvZGluZyBGYWN0b3JzIGFuZCBmb3JjaW5nIE5BIGZvciBjaGFyIGNvbHVtbnMNCg0KYGBge3J9DQp0cmFpbl9kYXRhW3RyYWluX2RhdGE9PSIiXSA8LSBOQQ0KdHJhaW5fZGF0YSRTZXg9ZmFjdG9yKHRyYWluX2RhdGEkU2V4LCBsZXZlbHM9YygibWFsZSIsImZlbWFsZSIpICxsYWJlbHMgPSBjKDAsMSkpDQp0cmFpbl9kYXRhJFBjbGFzcz1mYWN0b3IodHJhaW5fZGF0YSRQY2xhc3MsIGxldmVscyA9IGMoMSwyLDMpLCBsYWJlbHMgPSBjKDAsMSwyKSkNCnRyYWluX2RhdGEkRW1iYXJrZWQ9ZmFjdG9yKHRyYWluX2RhdGEkRW1iYXJrZWQsIGxldmVscyA9IGMoIkMiLCJRIiwiUyIpLCBsYWJlbHMgPSBjKDAsMSwyKSkNCnRyYWluX2RhdGEkU3Vydml2ZWQ9ZmFjdG9yKHRyYWluX2RhdGEkU3Vydml2ZWQpDQp0cmFpbl9kYXRhDQpgYGANCg0KDQoNCg0KDQojIEV4cGxvcmluZyB0aGUgZGF0YQ0KDQpgYGB7cn0NCnRyYWluX2RhdGENCmBgYA0KDQpgYGB7cn0NCnN1bW1hcnkodHJhaW5fZGF0YSkNCmBgYA0KDQoNCjEuIEknbSBwcmVkaWN0aW5nIFN1cnZpdmVkDQoNCjIuIEludHVpdGl2ZWx5LCBJJ2QgZXhwZWN0IFBjbGFzcyB0byBiZSBhIHNpZ25pZmljYW50IHByZWRpY3Rvcg0KDQozLiBMaWtld2lzZSwgZG9uJ3Qgd29tZW4gYW5kIGNoaWxkcmVuIGFsd2F5cyBnbyBmaXJzdD8gU28gYWdlIGFuZCBzZXggc2hvdWxkIGJlIHZhbHVhYmxlIHByZWRpY3RvcnMuDQoNCjQuIFNpYlNwIHJlcHJlc2VudHMgdGhlIG51bWJlciBvZiBzaWJsaW5ncy9zcG91c2VzIGFib2FyZC4gTWF5YmUgaW1wb3J0YW50PyBJZiB0aGVyZSBhcmUgcGVvcGxlIHdpdGggeW91IHRoZXkgbWlnaHQgaGVscCB5b3UgZXNjYXBlLCBidXQgeW91IG1pZ2h0IGFsc28gc3RheSBiZWhpbmQgZm9yIHRoZW0uDQoNCjUuIFBhcmNoIGlzIHRoZSBudW1iZXIgb2YgcGFyZW50cyBvciBjaGlsZHJlbiBhYmJvYXJkLiBJZiB5b3UgYXJlIHlvdW5nIEknZCBleHBlY3QgaGlnaGVyIG51bWJlciBvZiBwYXJlbnRzIGluY3JlYXNlcyB5b3VyIGNoYW5jZSwgd2hpbGUgaWYgeW91IGFyZSBvbGRlciB0aGUgbnVtYmVyIG9mIGNoaWxkcmVuIG1pZ2h0IGNhdXNlIHlvdSB0byBob2xkIGJhY2sgdHJ5aW5nIHRvIGhlbHAgdGhlbS4NCg0KNi4gSW5mb3JtYXRpb24gaW4gZmFyZSBpcyBwcm9iYWJseSBjb250YWluZWQgaW4gY2xhc3MNCg0KNy4gQ2FiaW4vVGlja2V0IHNlZW0gdW5saWtlbHkgdG8gcHJvdmlkZSBtdWNoIG1lYW5pbmdmdWwgaW5mb3JtYXRpb24NCg0KOC4gZW1iYXJrZWQgaXMgdGhlIHBvcnQgb2YgZW1iYXJrYXRpb24uIFVubGlrZWx5IHRvIGhlbHAgbXVjaCwgYnV0IEknbSBub3QgdGhhdCBjb25maWRlbnQgYWJvdXQgaXQuDQoNCkFsbCB0b2xkIG91ciBiaWcgZmFjdG9ycyBhcmUgcGNsYXNzLCBhZ2UsIHNleCwgc2lic3AsIHBhcmNoLiBNYXliZSBlbWJhcmtlZC4NCg0KYGBge3J9DQpnZ3Bsb3QodHJhaW5fZGF0YSkrDQogIGdlb21fdmlvbGluKGFlcyh4PVN1cnZpdmVkLCB5ID0gQWdlLCBmaWxsID0gU3Vydml2ZWQpKQ0KYGBgDQpSaWdodCBhd2F5IHdlIGFyZSByZW1pbmRlZCBvZiAxNzcgbWlzc2luZyBhZ2UgdmFsdWVzIHNlZW4gaW50aGUgc3VtbWFyeS4NCg0KV2UgY2FuIGFsc28gc2VlIHRoYXQgdGhlIGRpZG50IHN1cnZpdmUgZ3JvdXAgaGFzIGhhcyBhIGhlYXZpZXIgd2VpZ2h0IGFyb3VuZCB0aGUgYWdlIG9mIDI1Lg0KDQpgYGB7cn0NCmdncGxvdCh0cmFpbl9kYXRhW3doaWNoKGlzLm5hKHRyYWluX2RhdGEkQWdlKSksXSkrDQogIGdlb21fYmFyKGFlcyh4PVN1cnZpdmVkLCBmaWxsID0gU3Vydml2ZWQpKQ0KYGBgDQoNCk1vc3Qgb2Ygb3VyIG1pc3NpbmcgdmFsdWVzIGRpZWQNCg0KYGBge3J9DQp0cmFpbl9kYXRhW3doaWNoKGlzLm5hKHRyYWluX2RhdGEkQWdlKSksXQ0KYGBgDQoNCg0KYGBge3J9DQpnZ3Bsb3QodHJhaW5fZGF0YSkrDQogIGdlb21fYmFyKGFlcyh4PVBjbGFzcywgZmlsbCA9IFN1cnZpdmVkKSkNCmBgYA0KVGlja2V0IGNsYXNzIGJyZWFrZG93biBpcyBhcyB5b3Ugd291bGQgZXhwZWN0Lg0KDQpgYGB7cn0NCmdncGxvdCh0cmFpbl9kYXRhKSsNCiAgZ2VvbV9iYXIoYWVzKHg9RW1iYXJrZWQsIGZpbGwgPSBTdXJ2aXZlZCkpDQpgYGANClRoZXJlIGlzIG1vcmUgaW5mcm9tYXRpb24gdGhhdCB5b3Ugd291bGQgZXhwZWN0IGhlcmUuIHRoZSBmaW5hbCBwb3J0IG9mIGVtYmFya2F0aW9uIChzb3V0aGhhbXB0b24pIGhhZCB0aGUgbW9zdCBwZW9wbGUsIGJ1dCBpdCBhbHNvIGhhcyB0aGUgd29yc3QgcGVyY2VudGFnZSBvZiBzdXJ2aXZhbC4NCg0KYGBge3J9DQpnZ3Bsb3QodHJhaW5fZGF0YSkrDQogIGdlb21fYmFyKGFlcyh4PVNpYlNwLCBmaWxsID0gU3Vydml2ZWQpKQ0KYGBgDQoNCk1vc3QgcGVvcGxlIGhhZCAwIHNwb3VzZXMgb3Igc2libGluZ3MgYWJvYXJkLCB0aGUgYmV0dGVyIHBlcmNlbnRhZ2UgYXQgMSBjb3VsZCBiZSBhdHRyaWJ1dGVkIGRpcmVjdGx5IHRvIHNwb3VzZSwgYnV0IHRoYXQgZG9lc24ndCBob2xkIHVwIGZvciB0aGUgYmV0dGVyIHBlcmNlbnRhZ2UgYXQgMg0KDQpgYGB7cn0NCmdncGxvdCh0cmFpbl9kYXRhKSsNCiAgZ2VvbV9iYXIoYWVzKHg9UGFyY2gsIGZpbGwgPSBTdXJ2aXZlZCkpDQpgYGANCkluY3JlYXNlZCBzdXJ2aXZhbCBhdCAxLCAyLCBhbmQgMy4gMSBhbmQgMiBhcmUgbW9zdCBsaWtlbHkgYmVpbmcgd2VpZ2h0ZWQgYnkgcGFyZW50cy4gMyBpcyBpbnRlcmVzdGluZy4NCg0KYGBge3J9DQpnZ3Bsb3QodHJhaW5fZGF0YSkrDQogIGdlb21fYmFyKGFlcyh4PVNleCwgZmlsbCA9IFN1cnZpdmVkKSkNCmBgYA0KDQpXb21lbiBzdXJ2aXZlZCBhdCBhIE1VQ0ggaGlnaGVyIHJhdGUuDQoNCmBgYHtyfQ0KdHJhaW5fZGF0YSRhZ2Vncm91cCA9IGlmZWxzZSh0cmFpbl9kYXRhJEFnZSA8IDE2LCAwLCBpZmVsc2UodHJhaW5fZGF0YSRBZ2UgPCA1MCwgMSwgMikpDQpnZ3Bsb3QodHJhaW5fZGF0YSkrDQogZ2VvbV9iYXIoYWVzKHg9YWdlZ3JvdXAsIGZpbGwgPSBTdXJ2aXZlZCkpDQpgYGANCg0KDQpDaGlsZHJlbiBzdXJ2aXZlLCB0aG9zZSA+IDUwIGhhcmRseSBkby4NCg0KDQojIERlYWxpbmcgd2l0aCBNaXNzaW5nIFZhbHVlcw0KDQpOb3cgdGhhdCB3ZSBoYXZlIGV4cGxvcmVkIHRoZSBkYXRhLCBsZXRzIGRlYWwgd2l0aCB0aGUgbWlzc2luZyB2YWx1ZXMgaW4gZW1iYXJrZWQgYW5kIGFnZS4gV2Ugd2lsbCBiZSB1c2luZyBzdXJ2aXZhbCwgcGNsYXNzLCBzZXgsIGFnZSwgc2lic3AsIHBhcmNoLCBhbmQgZW1iYXJrZWQgdG8gcHJlZGljdCB0aGUgb3RoZXJzDQoNCmBgYHtyfQ0KY2xlYW5fZGF0YSA9IHRyYWluX2RhdGFbLGMoMiwzLDUsNiw3LDgsIDEyKV0NCmNsZWFuX2RhdGENCmBgYA0KDQojIyBFbWJhcmtlZA0KYGBge3J9DQpjbGVhbl9kYXRhX2VtYmFya2VkID0gY2xlYW5fZGF0YVstd2hpY2goaXMubmEodHJhaW5fZGF0YSRFbWJhcmtlZCkpLF0NCmNsZWFuX2RhdGFfZW1iYXJrZWQNCmBgYA0KDQojIyMgVGVzdC9UcmFpbiBTcGxpdA0KDQoNCmBgYHtyfQ0Kc2V0LnNlZWQoMTIzNCkNCnNwbGl0ID0gc2FtcGxlLnNwbGl0KGNsZWFuX2RhdGFfZW1iYXJrZWQkU3Vydml2ZWQsIFNwbGl0UmF0aW8gPSAwLjgpDQp0cmFpbiA9IHN1YnNldChjbGVhbl9kYXRhX2VtYmFya2VkLCBzcGxpdCA9PSBUUlVFKSANCnRlc3QgPSBzdWJzZXQoY2xlYW5fZGF0YV9lbWJhcmtlZCwgc3BsaXQgPT0gRkFMU0UpDQpgYGANCg0KDQojIyMgTW9kZWwNCg0KYGBge3J9DQpzZXQuc2VlZCgxMjM0KQ0KcmYuRW1iYXJrZWQgPSByYW5kb21Gb3Jlc3QoRW1iYXJrZWR+U3Vydml2ZWQgKyBQY2xhc3MrU2V4K1NpYlNwK1BhcmNoLCBkYXRhID0gY2xlYW5fZGF0YV9lbWJhcmtlZCxpbXBvcnRhbmNlID1UUlVFLCBtdHJ5ID0gMykNCmltcG9ydGFuY2UocmYuRW1iYXJrZWQpDQpgYGANCg0KYGBge3J9DQp5aGF0LkVtYmFya2VkID0gcHJlZGljdChyZi5FbWJhcmtlZCxuZXdkYXRhPXRlc3QsIHR5cGU9InJlc3BvbnNlIikNCmNvbmZ1c2lvbl9tYXRyaXggPSB0YWJsZSh0ZXN0JEVtYmFya2VkLHloYXQuRW1iYXJrZWQpDQpjb25mdXNpb25fbWF0cml4DQpgYGANCmBgYHtyfQ0KMTI0LygxMjErMTYrMzArMiszKQ0KYGBgDQpOb3QgZ3JlYXQgcHJlZGljdGl2ZSBwb3dlciwgYnV0IGJhc2ljYWxseSB3ZSBvbmx5IGFyZSByZXBsYWNpbmcgdHdvIHZhbHVlcy4gKHdpdGggMiBtb3N0IGxpa2VseSkgSSBjb3VsZCBkbyBtb3JlIGhlcmUgYnkgbG9va2luZyBhdCBvdGhlciBwcmVkaWN0b3JzIHRoYXQgQVJFIHByb2JhYmx5IHByZWRpY3RpdmUgb2YgbG9jYXRpb24gbGlrZSBmYXJlIGFuZCB0aWNrZXQsIGJ1dCBmb3IgdGhlIHNha2Ugb2YgdGltZSBJJ20ganVzdCBnb2luZyB0byBsZWF2ZSBpdCBhdCBlbWJhcmthdGlvbiA9IDINCg0KYGBge3J9DQp0cmFpbl9kYXRhJEVtYmFya2VkW3doaWNoKGlzLm5hKHRyYWluX2RhdGEkRW1iYXJrZWQpKV0gPSAyDQpjbGVhbl9kYXRhJEVtYmFya2VkW3doaWNoKGlzLm5hKGNsZWFuX2RhdGEkRW1iYXJrZWQpKV0gPSAyDQpgYGANCg0KDQojIyBBZ2UNCmBgYHtyfQ0KY2xlYW5fZGF0YV9hZ2UgPSBjbGVhbl9kYXRhWy13aGljaChpcy5uYSh0cmFpbl9kYXRhJEFnZSkpLF0NCmNsZWFuX2RhdGFfYWdlID0gY2xlYW5fZGF0YV9hZ2VbLC0xXSAjQ2FuJ3QgdXNlIHN1cnZpdmVkIGhlcmUgYmVjYXVzZSBPRyB0ZXN0IHNldCBkb2Vzbid0IHRlbGwgbWUgc3Vydml2ZWQuDQpjbGVhbl9kYXRhX2FnZQ0KYGBgDQoNCg0KIyMjIFRlc3QvVHJhaW4gU3BsaXQNCg0KDQpgYGB7cn0NCnNldC5zZWVkKDEyMzQpDQpzcGxpdCA9IHNhbXBsZS5zcGxpdChjbGVhbl9kYXRhX2FnZSRBZ2UsIFNwbGl0UmF0aW8gPSAwLjgpDQp0cmFpbiA9IHN1YnNldChjbGVhbl9kYXRhX2FnZSwgc3BsaXQgPT0gVFJVRSkgDQp0ZXN0ID0gc3Vic2V0KGNsZWFuX2RhdGFfYWdlLCBzcGxpdCA9PSBGQUxTRSkNCmBgYA0KDQoNCiMjIyBNb2RlbA0KDQoNCg0KDQpgYGB7cn0NCnNldC5zZWVkKDEyMzQpDQpyZi5BZ2UgPSByYW5kb21Gb3Jlc3QoQWdlfi4sIGRhdGEgPSBjbGVhbl9kYXRhX2FnZSxpbXBvcnRhbmNlID1UUlVFLCBtdHJ5ID0gNCkNCmltcG9ydGFuY2UocmYuQWdlKQ0KYGBgDQoNCmBgYHtyfQ0KeWhhdC5BZ2UgPSBwcmVkaWN0KHJmLkFnZSxuZXdkYXRhPXRlc3QpDQptZWFuKCh5aGF0LkFnZS10ZXN0JEFnZSleMikNCmBgYA0KDQpvb29vcGggdGhhdCBpcyBhIGEgbm90IGdyZWF0IG1lYW4gc3F1YXJlZCBlcnJvciwgYnV0IGxldHMga2VlcCByb2xsaW5nIHdpdGggaXQgZm9yIG5vdy4NCg0KYGBge3J9DQpjbGVhbl9kYXRhJEFnZVt3aGljaChpcy5uYShjbGVhbl9kYXRhJEFnZSkpXSA9IHByZWRpY3QocmYuQWdlLCBuZXdkYXRhID0gY2xlYW5fZGF0YVt3aGljaChpcy5uYShjbGVhbl9kYXRhJEFnZSkpLF0pDQp0cmFpbl9kYXRhJEFnZVt3aGljaChpcy5uYSh0cmFpbl9kYXRhJEFnZSkpXSA9IHByZWRpY3QocmYuQWdlLCBuZXdkYXRhID0gdHJhaW5fZGF0YVt3aGljaChpcy5uYSh0cmFpbl9kYXRhJEFnZSkpLF0pDQpgYGANCg0KDQojIE1vZGVkbCBCdWlsZGluZw0KDQpgYGB7cn0NCmNsZWFuX2RhdGENCmBgYA0KDQoNCmBgYHtyfQ0Kc2V0LnNlZWQoMTIzNCkNCnNwbGl0ID0gc2FtcGxlLnNwbGl0KGNsZWFuX2RhdGEkU3Vydml2ZWQsIFNwbGl0UmF0aW8gPSAwLjgpDQp0cmFpbiA9IHN1YnNldChjbGVhbl9kYXRhLCBzcGxpdCA9PSBUUlVFKSANCnRlc3QgPSBzdWJzZXQoY2xlYW5fZGF0YSwgc3BsaXQgPT0gRkFMU0UpDQpgYGANCg0KDQpgYGB7cn0NCnJmLlN1cnZpdmVkID0gcmFuZG9tRm9yZXN0KFN1cnZpdmVkfi4sIGRhdGEgPSB0cmFpbixpbXBvcnRhbmNlID1UUlVFKQ0KeWhhdC5TdXJ2aXZlZCA9IHByZWRpY3QocmYuU3Vydml2ZWQsbmV3ZGF0YT10ZXN0LCB0eXBlPSJyZXNwb25zZSIpDQpjb25mdXNpb25fbWF0cml4ID0gdGFibGUodGVzdCRTdXJ2aXZlZCx5aGF0LlN1cnZpdmVkKQ0KY29uZnVzaW9uX21hdHJpeA0KYGBgDQpgYGB7cn0NCjE0MC8xNzgNCmBgYA0Kbm90IGJhZCwgYnV0IGhvdyBkb2VzIGl0IGNvbXBhcmUgdG8gZ2VuZGVyPw0KDQpgYGB7cn0NCnloYXQuZ2VuZGVyID0gaWZlbHNlKHRlc3QkU2V4ID09IDEsIDEsIDApDQpjb25mdXNpb25fbWF0cml4ID0gdGFibGUodGVzdCRTdXJ2aXZlZCx5aGF0LmdlbmRlcikNCmNvbmZ1c2lvbl9tYXRyaXgNCmBgYA0KYGBge3J9DQoxMzYvMTc4DQpgYGANCkJldHRlciwgYnV0IG5vdCBUSEFUIG11Y2ggYmV0dGVyLiBMZXQncyBnbyBhaGVhZCBhbmQgY2xlYW4gdXAgdGhlIHRlc3QgZGF0YSBhbmQgc3VibWl0DQoNCiMgVGVzdCBEYXRhIENsZWFudXANCmBgYHtyfQ0KdGVzdF9kYXRhDQpgYGANCg0KYGBge3J9DQp0ZXN0X2RhdGENCmBgYA0KDQoNCmBgYHtyfQ0KdGVzdF9kYXRhJFNleD1mYWN0b3IodGVzdF9kYXRhJFNleCwgbGV2ZWxzPWMoIm1hbGUiLCJmZW1hbGUiKSAsbGFiZWxzID0gYygwLDEpKQ0KdGVzdF9kYXRhJFBjbGFzcz1mYWN0b3IodGVzdF9kYXRhJFBjbGFzcywgbGV2ZWxzID0gYygxLDIsMyksIGxhYmVscyA9IGMoMCwxLDIpKQ0KdGVzdF9kYXRhJEVtYmFya2VkPWZhY3Rvcih0ZXN0X2RhdGEkRW1iYXJrZWQsIGxldmVscyA9IGMoIkMiLCJRIiwiUyIpLCBsYWJlbHMgPSBjKDAsMSwyKSkNCnRlc3RfZGF0YV9jbGVhbiA9IHRlc3RfZGF0YVssYygyLDQsNSw2LDcsMTEpXQ0KdGVzdF9kYXRhX2NsZWFuDQpgYGANCg0KYGBge3J9DQpzdW1tYXJ5KHRlc3RfZGF0YV9jbGVhbikNCmBgYA0KT25seSBtaXNzaW5nIHZhbHVlcyBpbiBBZ2UNCg0KDQpgYGB7cn0NCnRlc3RfZGF0YV9jbGVhbiRBZ2Vbd2hpY2goaXMubmEodGVzdF9kYXRhX2NsZWFuJEFnZSkpXT1wcmVkaWN0KHJmLkFnZSx0ZXN0X2RhdGFfY2xlYW5bd2hpY2goaXMubmEodGVzdF9kYXRhX2NsZWFuJEFnZSkpLF0pDQpgYGANCg0KDQpgYGB7cn0NCnRlc3RfZGF0YV9jbGVhbg0KYGBgDQoNCg0KDQpgYGB7cn0NClJmZ3Vlc3MgPSBkYXRhLmZyYW1lKHRlc3RfZGF0YSRQYXNzZW5nZXJJZCwgcHJlZGljdChyZi5TdXJ2aXZlZCx0ZXN0X2RhdGFfY2xlYW4pKQ0KY29sbmFtZXMoUmZndWVzcykgPC0gYygiUGFzc2VuZ2VySWQiLCJTdXJ2aXZlZCIpDQpSZmd1ZXNzDQpgYGANCg0KYGBge3J9DQp3cml0ZS5jc3YoUmZndWVzcywgInJmZ3Vlc3MuY3N2Iixyb3cubmFtZXMgPSBGQUxTRSkNCmBgYA0KDQpGaW5hbCBzY29yZTogMC43Nzc1MSwgbm90IGdyZWF0IGJ1dCBJJ20gaW4gdGhlIHRvcCBxdWFydGVyIGFuZCBpbXByb3ZlZCBvdmVyIHRoZSBnZW5kZXIgZ3Vlc3NlcyBhdCBsZWFzdCEgDQoNCmBgYHtyfQ0KYmFnZ2VkLlN1cnZpdmVkID0gcmFuZG9tRm9yZXN0KFN1cnZpdmVkfi4sIGRhdGEgPSB0cmFpbixpbXBvcnRhbmNlID1UUlVFLCBtdHJ5ID0gNikNCnloYXQuU3Vydml2ZWQgPSBwcmVkaWN0KGJhZ2dlZC5TdXJ2aXZlZCxuZXdkYXRhPXRlc3QsIHR5cGU9InJlc3BvbnNlIikNCmNvbmZ1c2lvbl9tYXRyaXggPSB0YWJsZSh0ZXN0JFN1cnZpdmVkLHloYXQuU3Vydml2ZWQpDQpjb25mdXNpb25fbWF0cml4DQpgYGANCmBgYHtyfQ0KMTEwLzE4OA0KYGBgDQphIGxvdCB3b3JzZQ0KYGBge3J9DQpCYWdnZWRndWVzcyA9IGRhdGEuZnJhbWUodGVzdF9kYXRhJFBhc3NlbmdlcklkLCBwcmVkaWN0KGJhZ2dlZC5TdXJ2aXZlZCx0ZXN0X2RhdGFfY2xlYW4pKQ0KY29sbmFtZXMoQmFnZ2VkZ3Vlc3MpIDwtIGMoIlBhc3NlbmdlcklkIiwiU3Vydml2ZWQiKQ0Kd3JpdGUuY3N2KEJhZ2dlZGd1ZXNzLCAiYmFndWVzcy5jc3YiLHJvdy5uYW1lcyA9IEZBTFNFKQ0KYGBgDQoNCg0KYGBge3J9DQpib29zdC5TdXJ2aXZlZCA9IGdibShhcy5jaGFyYWN0ZXIoU3Vydml2ZWQpfi4sIGRhdGEgPSB0cmFpbiwgZGlzdHJpYnV0aW9uPSJiZXJub3VsbGkiLCBuLnRyZWUgPSA1MDAwKQ0KYmVzdC5pdGVyIDwtIGdibS5wZXJmKGJvb3N0LlN1cnZpdmVkLCBtZXRob2QgPSAiT09CIiwgcGxvdCA9IEZBTFNFKQ0KYmVzdC5pdGVyDQpgYGANCmBgYHtyfQ0KcHJvYiA9IHByZWRpY3QoYm9vc3QuU3Vydml2ZWQsIG5ld2RhdGE9dGVzdCwgYmVzdC5pdGVyLHR5cGU9InJlc3BvbnNlIikNCnloYXQuU3Vydml2ZWQgPSBpZmVsc2UocHJvYj4uNSwgMSwgMCkNCmNvbmZ1c2lvbl9tYXRyaXggPSB0YWJsZSh0ZXN0JFN1cnZpdmVkLHloYXQuU3Vydml2ZWQpDQpjb25mdXNpb25fbWF0cml4DQpgYGANCmBgYHtyfQ0KMTQwLzE3OA0KYGBgDQpTYW1lIGFzIFJGDQoNCmBgYHtyfQ0KYm9vc3RlZGd1ZXNzID0gZGF0YS5mcmFtZSh0ZXN0X2RhdGEkUGFzc2VuZ2VySWQsIHByZWRpY3QoYm9vc3QuU3Vydml2ZWQsdGVzdF9kYXRhX2NsZWFuKSkNCmNvbG5hbWVzKGJvb3N0ZWRndWVzcykgPC0gYygiUGFzc2VuZ2VySWQiLCJTdXJ2aXZlZCIpDQp3cml0ZS5jc3YoYm9vc3RlZGd1ZXNzLCAiYm9ndWVzcy5jc3YiLHJvdy5uYW1lcyA9IEZBTFNFKQ0KYGBgDQoNCg0KDQoNCg0K
]]>Bagging Random Forest and Boosting2021-06-14T00:00:00+00:002021-06-14T00:00:00+00:00https://www.ndled.us/stats/2021/06/14/Bagging-Random-Forest-and-Boosting Bagging, Random Forest, and Boosting 
library(ISLR)
library(tidyverse)
library(randomForest)
library(gbm)
library(MASS)
library(rpart)

Bagging

Motivation:

Decision trees discussed previously have high variance. Imagine we split the data into two parts at random and fit a decision tree to both halves. The results could be extremely different. What we want to do is find a procedure with low variance that will give similar results when applied over and over again.

Reminder about Trees

data = read.csv("50_Startups.csv")
head(data)
set.seed(1)
split = sample (1:nrow(Boston), nrow(Boston)/2)
regressor2 = rpart(formula = Profit ~ R.D.Spend, data= data, subset = split, control = rpart.control(minsplit = 2))
xgrid = seq(min(data$R.D.Spend),max(data$R.D.Spend),1)
ggplot() +
  geom_point(aes(x = data$R.D.Spend, y = data$Profit), color = 'red')+
  geom_line(aes(x = xgrid, y = predict(regressor2, newdata = data.frame(R.D.Spend = xgrid))), color = 'blue')

set.seed(1)
split = sample (1:nrow(Boston), nrow(Boston)/2)
regressor2 = rpart(formula = Profit ~ R.D.Spend, data= data, subset = -split, control = rpart.control(minsplit = 2))
xgrid = seq(min(data$R.D.Spend),max(data$R.D.Spend),1)
ggplot() +
  geom_point(aes(x = data$R.D.Spend, y = data$Profit), color = 'red')+
  geom_line(aes(x = xgrid, y = predict(regressor2, newdata = data.frame(R.D.Spend = xgrid))), color = 'blue')

Bagging also known as bootstrap aggregation will reduce the variance of a statistical learning method.

Ignoring the math for a moment, consider the the following intuition; Averaging a set of observations reduces the variance, so we could reduce the variance and increase the accuracy of our decision tree by taking many training sets from the population, building distinct trees, and averaging the results to obtain a single low variance model.

Unfortunately, we don’t expect to have access to multiple training sets. We can, however, bootstrap and take repeated samples from the single training set. This is called Bagging and works for lots of different statistical learning methods, but is especially useful for decision trees. Our procedure to implement this method begins by constructing B regression trees using B bootstrapped training sets and then averaging the results.

This gives us the following equation

Note These trees should be grown deep and not be pruned, so an individual tree should have high variance and low bias.

Out of Bag Error Estimation (OOB)

We don’t need to cross validate OR use the validation set approach! Instead, we can use the Out of Bag Error Estimate

Recall that the key to bagging is that trees are repeatedly fit to bootstrapped subsets of the observations and that, as Dr. White mentioned in his bootstrap lecture, each bagged tree will only use about 2/3rds of the observations. The remaining one third of the observations for a given bagged tree are referred to as the out of bag observations.

We can predict the response for the ith observation using each of the trees in which that observation was OOB. This will yield around B/3 predictions for the ith observation. Then, we can find a single prediction by averaging these predictions or take a majority vote. This ultimately leads to an overall OOB MSE which is a valid estimate of the test error for the bagged model.

Application of Bagging

Now to a good example on the Boston dataset

Training our Model

set.seed(12)
train = sample (1:nrow(Boston), nrow(Boston)/2)
bag.boston = randomForest(medv~., data = Boston, subset = train, mtry = 13, importance = TRUE)
# mtry -    Number of variables randomly sampled as candidates at each split. Note that the default values are different for classification (sqrt(p) where p is number of variables in x) and regression (p/3)
bag.boston

Call:
 randomForest(formula = medv ~ ., data = Boston, mtry = 13, importance = TRUE,      subset = train) 
               Type of random forest: regression
                     Number of trees: 500
No. of variables tried at each split: 13

          Mean of squared residuals: 14.09328
                    % Var explained: 84.14

Testing our Model

The OOB estimate for MSE is 14.09

yhat.bag = predict (bag.boston , newdata=Boston[-train ,])
ggplot()+
  geom_point(aes(x = yhat.bag, y = Boston[-train, "medv"]))+
  geom_abline(color = "red")+
  xlab("Predicted Values")+
  ylab("True Values")

mean((yhat.bag -Boston[-train, "medv"])^2)
[1] 14.08248

The test set MSE associated with the bagged regression tree is 14.08, this is an improvement over the textbook example of a single optimally pruned tree.

set.seed(1)
bag.boston2 = randomForest(medv~., data = Boston, subset = train, mtry = 13, importance = TRUE, ntree = 1000)
yhat.bag2 = predict (bag.boston2 , newdata=Boston[-train ,])
mean((yhat.bag2 -Boston[-train, "medv"])^2)
[1] 14.06875

Interpretation

It’s not great. When we bag a large number of trees, it is no longer possible to represent the model with a single tree and it is no longer clear which variables are most important to the precedure.

Bagging improves the accuracy at the expense of interpretability

We do have some tools to identify importance though, we can use the RSS for regression trees or Gini index (Probability that a feature is classified incorrectly when selected randomly) for classification.

For regression - We can look at the total amount the RSS (Sum of Squared Residuals if you, like me, forgot) has decreased due to splits over a given predictor.

For classification - We can do the same with the Gini index measure.

Random Forest

This is an improvement over bagged trees by decorrelating the trees. We still build multiple decision trees on bootstrapped training samples, but instead of using all predictors, we use only a random sample from the full set of predictors. Typically we choose the number of predictors to be approximately equal to the square root of the total number of predictors.

Weird but works! Why wouldn’t we want the trees to be built on all available data? How does this decorrelate the trees?

From the textbook “Suppose that there is one very strong predictor in the data set, along with a number of other moderately strong predictors. Then in the collection of bagged trees, most or all of the trees will use this strong predictor in the top split. Consequently, all of the bagged trees will look quite similar to each other. Hence the predictions from the bagged trees will be highly correlated.”

We know that averaging over highly correlated values doesn’t reduce the variance as much as doing so with uncorrelated values. This means that bagging doesn’t reduce the variance as much as we would like.

Random forest deals with this by forcing each tree to only consider a subset of the predictors. In the textbook example, this leads to some trees not even considering the strong predictor.

Main difference between random forest and bagging is the choise of predictor subset size

This leads to a reduction in both test error and OOB error over bagging. Basically use randomforest, not bagging.

Note Sometimes we may want to use less than the suggested number of predictors when variables are highly correlated. The randomForest library in R defaults to p/3 for regression trees.

Application of Randomforest

set.seed(1)
rf.boston= randomForest(medv ~ .,data=Boston, subset=train, mtry=6, importance =TRUE)
yhat.rf = predict(rf.boston ,newdata=Boston[- train ,])
mean((yhat.rf-Boston[-train, "medv"])^2)
[1] 12.94768

Wow! Look at how much better that is. Let’s see if we can understand what predictors are important.

importance(rf.boston)
          %IncMSE IncNodePurity
crim    14.162597    1495.43316
zn       2.354257      57.80273
indus    7.026734     721.89977
chas     4.271671      84.36145
nox     13.310095     907.93589
rm      34.210395    7223.81670
age      7.855808     317.85702
dis     13.120051    1058.37980
rad      4.263160     159.48436
tax      8.696159     641.37864
ptratio 14.993781    1405.86289
black    5.980337     264.13753
lstat   31.040048    7704.31207

We see the %increase in MSE which is a measure of the decrease in accuracy in prediction on the OOB samples when a given variable is excluded.

We also see the total decrease in node impurity that results from splits over that variable (averaged over all trees.) For regression that is measured over RSS and for classification by deviance.

We can plot this!

varImpPlot(rf.boston)

Boosting

Boosting is another general approach we can use to improve statistical learning methods. Boosting works like bagging does with multiple trees, but doesn’t use boot strapping and instead each tree is fit on a modified version of the original data. The main difference is that in boosting trees are grown sequentially based on information learned in previous trees

What is interesting about this?

• Unlike fitting a single large decision tree to the data, which amounts to fitting the data hard and potentially overfitting, the boosting approach instead learns slowly.

• Given the current model, we fit a decision tree to the residuals from the model. We then add this new decision tree into the fitted function in order to update the residuals.

• Each of these trees can be rather small, with just a few terminal nodes, determined by the parameter d in the algorithm.

• By fitting small trees to the residuals, we slowly improve f in areas where it does not perform well. The shrinkage parameter λ slows the process down even further, allowing more and different shaped trees to attack the residuals.

Tuning Parameters for Boosting

  1. The number of trees B. Unlike bagging and random forests, boosting can overfit if B is too large, although this overfitting tends to occur slowly if at all. We use cross-validation to select B.

  2. The shrinkage parameter λ, a small positive number. This controls the rate at which boosting learns. Typical values are 0.01 or 0.001, and the right choice can depend on the problem. Very small λ can require using a very large value of B in order to achieve good performance.

  3. The number of splits d in each tree, which controls the complexity of the boosted ensemble. Often d = 1 works well, in which case each tree is a stump, consisting of a single split and resulting in an additive model. More generally d is the interaction depth, and controls the interaction order of the boosted model, since d splits can involve at most d variables.

Application

set.seed(12)
boost.boston=gbm(medv~.,data=Boston[train ,], distribution="gaussian",n.trees=5000, interaction.depth=4)
summary(boost.boston)

Clearly rm and lstat are the most influential, lets take a look at them individually

plot(boost.boston ,i="rm")

plot(boost.boston ,i="lstat")

yhat.boost=predict (boost.boston ,newdata =Boston[-train ,])#, n.trees=??)
Using 5000 trees...
best.iter <- gbm.perf(boost.boston, method = "OOB", plot = FALSE)
OOB generally underestimates the optimal number of iterations although predictive performance is reasonably competitive. Using cv_folds>1 when calling gbm usually results in improved predictive performance.
print(best.iter)
[1] 102
attr(,"smoother")
Call:
loess(formula = object$oobag.improve ~ x, enp.target = min(max(4, 
    length(x)/10), 50))

Number of Observations: 5000 
Equivalent Number of Parameters: 39.99 
Residual Standard Error: 0.2303 
set.seed(1)
yhat.boost=predict (boost.boston ,newdata =Boston[-train ,], n.trees=103)
mean((yhat.boost-Boston[-train, "medv"])^2)
[1] 15.88817

Not a great MSE, but still better than bagging. Let’s try to tune it with lambda

set.seed(1)
boost.boston2=gbm(medv~.,data=Boston[train ,], distribution="gaussian",n.trees=5000, interaction.depth=5, shrinkage =.1)
best.iter <- gbm.perf(boost.boston2, method = "OOB",plot = FALSE)
OOB generally underestimates the optimal number of iterations although predictive performance is reasonably competitive. Using cv_folds>1 when calling gbm usually results in improved predictive performance.
yhat.boost2=predict (boost.boston2 ,newdata =Boston[-train ,], n.trees=best.iter)
mean((yhat.boost2-Boston[-train, "medv"])^2)
[1] 12.95806

An improvement!

##Classification

data = read.csv("Social_Network_Ads.csv")
head(data)
set.seed(1234)
data$Age=scale(data$Age)
data$EstimatedSalary=scale(data$EstimatedSalary)
train = sample (1:nrow(data), nrow(data)/2)
classifier = randomForest(factor(Purchased)~EstimatedSalary + Age, data = data, subset= train, ntree = 10)
yhat = predict(classifier, newdata=data[-train ,])
confusion_matrix = table(data[-train, 5],yhat)
confusion_matrix
   yhat
      0   1
  0 109  14
  1  11  66
test = data[-train, ]
X1 = seq(min(test$EstimatedSalary) - 1, max(test$EstimatedSalary) + 1, by = 0.1)
X2 = seq(min(test$Age) - 1, max(test$Age) + 1, by = 0.1)
grid = expand.grid(X1,X2)
colnames(grid) = c("EstimatedSalary","Age")
prob = predict(classifier, type = "response", newdata = grid)
ggplot()+
  geom_point(data = grid, aes(x=EstimatedSalary,y=Age, color = prob), size = .1)+
  geom_point(aes(x=EstimatedSalary, y = Age, color= factor(Purchased)), data = test)+
  geom_contour(aes(x=grid$EstimatedSalary, y = grid$Age, z=as.numeric(prob)))

##HW

  1. Repeat the previous classification example using bagging and boosting methods and comment on any differences you observe.
LS0tDQp0aXRsZTogIkJhZ2dpbmcsIFJhbmRvbSBGb3Jlc3QsIGFuZCBCb29zdGluZyINCm91dHB1dDogaHRtbF9ub3RlYm9vaw0KLS0tDQoNCmBgYHtyfQ0KbGlicmFyeShJU0xSKQ0KbGlicmFyeSh0aWR5dmVyc2UpDQpsaWJyYXJ5KHJhbmRvbUZvcmVzdCkNCmxpYnJhcnkoZ2JtKQ0KbGlicmFyeShNQVNTKQ0KbGlicmFyeShycGFydCkNCmBgYA0KIyMgQmFnZ2luZw0KDQojIyMgTW90aXZhdGlvbjoNCkRlY2lzaW9uIHRyZWVzIGRpc2N1c3NlZCBwcmV2aW91c2x5IGhhdmUgKmhpZ2ggdmFyaWFuY2UqLiBJbWFnaW5lIHdlIHNwbGl0IHRoZSBkYXRhIGludG8gdHdvIHBhcnRzIGF0IHJhbmRvbSBhbmQgZml0IGEgZGVjaXNpb24gdHJlZSB0byBib3RoIGhhbHZlcy4gVGhlIHJlc3VsdHMgY291bGQgYmUgZXh0cmVtZWx5IGRpZmZlcmVudC4gV2hhdCB3ZSB3YW50IHRvIGRvIGlzIGZpbmQgYSBwcm9jZWR1cmUgd2l0aCAqbG93IHZhcmlhbmNlKiB0aGF0IHdpbGwgZ2l2ZSBzaW1pbGFyIHJlc3VsdHMgd2hlbiBhcHBsaWVkIG92ZXIgYW5kIG92ZXIgYWdhaW4uDQoNCioqUmVtaW5kZXIgYWJvdXQgVHJlZXMqKg0KDQpgYGB7cn0NCmRhdGEgPSByZWFkLmNzdigiNTBfU3RhcnR1cHMuY3N2IikNCmhlYWQoZGF0YSkNCmBgYA0KDQpgYGB7cn0NCnNldC5zZWVkKDEpDQpzcGxpdCA9IHNhbXBsZSAoMTpucm93KEJvc3RvbiksIG5yb3coQm9zdG9uKS8yKQ0KcmVncmVzc29yMiA9IHJwYXJ0KGZvcm11bGEgPSBQcm9maXQgfiBSLkQuU3BlbmQsIGRhdGE9IGRhdGEsIHN1YnNldCA9IHNwbGl0LCBjb250cm9sID0gcnBhcnQuY29udHJvbChtaW5zcGxpdCA9IDIpKQ0KeGdyaWQgPSBzZXEobWluKGRhdGEkUi5ELlNwZW5kKSxtYXgoZGF0YSRSLkQuU3BlbmQpLDEpDQpnZ3Bsb3QoKSArDQogIGdlb21fcG9pbnQoYWVzKHggPSBkYXRhJFIuRC5TcGVuZCwgeSA9IGRhdGEkUHJvZml0KSwgY29sb3IgPSAncmVkJykrDQogIGdlb21fbGluZShhZXMoeCA9IHhncmlkLCB5ID0gcHJlZGljdChyZWdyZXNzb3IyLCBuZXdkYXRhID0gZGF0YS5mcmFtZShSLkQuU3BlbmQgPSB4Z3JpZCkpKSwgY29sb3IgPSAnYmx1ZScpDQpgYGANCg0KYGBge3J9DQpzZXQuc2VlZCgxKQ0Kc3BsaXQgPSBzYW1wbGUgKDE6bnJvdyhCb3N0b24pLCBucm93KEJvc3RvbikvMikNCnJlZ3Jlc3NvcjIgPSBycGFydChmb3JtdWxhID0gUHJvZml0IH4gUi5ELlNwZW5kLCBkYXRhPSBkYXRhLCBzdWJzZXQgPSAtc3BsaXQsIGNvbnRyb2wgPSBycGFydC5jb250cm9sKG1pbnNwbGl0ID0gMikpDQp4Z3JpZCA9IHNlcShtaW4oZGF0YSRSLkQuU3BlbmQpLG1heChkYXRhJFIuRC5TcGVuZCksMSkNCmdncGxvdCgpICsNCiAgZ2VvbV9wb2ludChhZXMoeCA9IGRhdGEkUi5ELlNwZW5kLCB5ID0gZGF0YSRQcm9maXQpLCBjb2xvciA9ICdyZWQnKSsNCiAgZ2VvbV9saW5lKGFlcyh4ID0geGdyaWQsIHkgPSBwcmVkaWN0KHJlZ3Jlc3NvcjIsIG5ld2RhdGEgPSBkYXRhLmZyYW1lKFIuRC5TcGVuZCA9IHhncmlkKSkpLCBjb2xvciA9ICdibHVlJykNCmBgYA0KDQoqKkJhZ2dpbmcqKiBhbHNvIGtub3duIGFzICoqYm9vdHN0cmFwIGFnZ3JlZ2F0aW9uKiogd2lsbCByZWR1Y2UgdGhlIHZhcmlhbmNlIG9mIGEgc3RhdGlzdGljYWwgbGVhcm5pbmcgbWV0aG9kLg0KDQpJZ25vcmluZyB0aGUgbWF0aCBmb3IgYSBtb21lbnQsIGNvbnNpZGVyIHRoZSB0aGUgZm9sbG93aW5nIGludHVpdGlvbjsgQXZlcmFnaW5nIGEgc2V0IG9mIG9ic2VydmF0aW9ucyByZWR1Y2VzIHRoZSB2YXJpYW5jZSwgc28gd2UgY291bGQgcmVkdWNlIHRoZSB2YXJpYW5jZSBhbmQgaW5jcmVhc2UgdGhlIGFjY3VyYWN5IG9mIG91ciBkZWNpc2lvbiB0cmVlIGJ5IHRha2luZyBtYW55IHRyYWluaW5nIHNldHMgZnJvbSB0aGUgcG9wdWxhdGlvbiwgYnVpbGRpbmcgZGlzdGluY3QgdHJlZXMsIGFuZCBhdmVyYWdpbmcgdGhlIHJlc3VsdHMgdG8gb2J0YWluIGEgc2luZ2xlIGxvdyB2YXJpYW5jZSBtb2RlbC4NCg0KVW5mb3J0dW5hdGVseSwgd2UgZG9uJ3QgZXhwZWN0IHRvIGhhdmUgYWNjZXNzIHRvIG11bHRpcGxlIHRyYWluaW5nIHNldHMuIFdlIGNhbiwgaG93ZXZlciwgYm9vdHN0cmFwIGFuZCB0YWtlIHJlcGVhdGVkIHNhbXBsZXMgZnJvbSB0aGUgc2luZ2xlIHRyYWluaW5nIHNldC4gVGhpcyBpcyBjYWxsZWQgKipCYWdnaW5nKiogYW5kIHdvcmtzIGZvciBsb3RzIG9mIGRpZmZlcmVudCBzdGF0aXN0aWNhbCBsZWFybmluZyBtZXRob2RzLCBidXQgaXMgZXNwZWNpYWxseSB1c2VmdWwgZm9yIGRlY2lzaW9uIHRyZWVzLiBPdXIgcHJvY2VkdXJlIHRvIGltcGxlbWVudCB0aGlzIG1ldGhvZCBiZWdpbnMgYnkgY29uc3RydWN0aW5nICpCKiByZWdyZXNzaW9uIHRyZWVzIHVzaW5nICpCKiBib290c3RyYXBwZWQgdHJhaW5pbmcgc2V0cyBhbmQgdGhlbiBhdmVyYWdpbmcgdGhlIHJlc3VsdHMuDQoNClRoaXMgZ2l2ZXMgdXMgdGhlIGZvbGxvd2luZyBlcXVhdGlvbg0KDQohW10oYmFnLnBuZykNCg0KKipOb3RlKiogVGhlc2UgdHJlZXMgc2hvdWxkIGJlIGdyb3duIGRlZXAgYW5kIG5vdCBiZSBwcnVuZWQsIHNvIGFuIGluZGl2aWR1YWwgdHJlZSBzaG91bGQgaGF2ZSBoaWdoIHZhcmlhbmNlIGFuZCBsb3cgYmlhcy4gDQoNCiMjIyBPdXQgb2YgQmFnIEVycm9yIEVzdGltYXRpb24gKE9PQikNCg0KV2UgZG9uJ3QgbmVlZCB0byBjcm9zcyB2YWxpZGF0ZSBPUiB1c2UgdGhlIHZhbGlkYXRpb24gc2V0IGFwcHJvYWNoISBJbnN0ZWFkLCB3ZSBjYW4gdXNlIHRoZSBPdXQgb2YgQmFnIEVycm9yIEVzdGltYXRlDQoNClJlY2FsbCB0aGF0IHRoZSBrZXkgdG8gYmFnZ2luZyBpcyB0aGF0IHRyZWVzIGFyZSByZXBlYXRlZGx5IGZpdCB0byBib290c3RyYXBwZWQgc3Vic2V0cyBvZiB0aGUgb2JzZXJ2YXRpb25zIGFuZCB0aGF0LCBhcyBEci4gV2hpdGUgbWVudGlvbmVkIGluIGhpcyBib290c3RyYXAgbGVjdHVyZSwgZWFjaCBiYWdnZWQgdHJlZSB3aWxsIG9ubHkgdXNlIGFib3V0IDIvM3JkcyBvZiB0aGUgb2JzZXJ2YXRpb25zLiBUaGUgcmVtYWluaW5nIG9uZSB0aGlyZCBvZiB0aGUgb2JzZXJ2YXRpb25zIGZvciBhIGdpdmVuIGJhZ2dlZCB0cmVlIGFyZSByZWZlcnJlZCB0byBhcyB0aGUgb3V0IG9mIGJhZyBvYnNlcnZhdGlvbnMuICANCg0KV2UgY2FuIHByZWRpY3QgdGhlIHJlc3BvbnNlIGZvciB0aGUgaXRoIG9ic2VydmF0aW9uIHVzaW5nIGVhY2ggb2YgdGhlIHRyZWVzIGluIHdoaWNoIHRoYXQgb2JzZXJ2YXRpb24gd2FzIE9PQi4gVGhpcyB3aWxsIHlpZWxkIGFyb3VuZCBCLzMgcHJlZGljdGlvbnMgZm9yIHRoZSBpdGggb2JzZXJ2YXRpb24uIFRoZW4sIHdlIGNhbiBmaW5kIGEgc2luZ2xlIHByZWRpY3Rpb24gYnkgYXZlcmFnaW5nIHRoZXNlIHByZWRpY3Rpb25zIG9yIHRha2UgYSBtYWpvcml0eSB2b3RlLiBUaGlzIHVsdGltYXRlbHkgbGVhZHMgdG8gYW4gb3ZlcmFsbCBPT0IgTVNFIHdoaWNoIGlzIGEgdmFsaWQgZXN0aW1hdGUgb2YgdGhlIHRlc3QgZXJyb3IgZm9yIHRoZSBiYWdnZWQgbW9kZWwuDQoNCg0KDQojIyMgQXBwbGljYXRpb24gb2YgQmFnZ2luZw0KDQoNCg0KTm93IHRvIGEgZ29vZCBleGFtcGxlIG9uIHRoZSBCb3N0b24gZGF0YXNldA0KDQoNCioqVHJhaW5pbmcgb3VyIE1vZGVsKioNCg0KYGBge3J9DQpzZXQuc2VlZCgxMikNCnRyYWluID0gc2FtcGxlICgxOm5yb3coQm9zdG9uKSwgbnJvdyhCb3N0b24pLzIpDQpiYWcuYm9zdG9uID0gcmFuZG9tRm9yZXN0KG1lZHZ+LiwgZGF0YSA9IEJvc3Rvbiwgc3Vic2V0ID0gdHJhaW4sIG10cnkgPSAxMywgaW1wb3J0YW5jZSA9IFRSVUUpDQojIG10cnkgLQlOdW1iZXIgb2YgdmFyaWFibGVzIHJhbmRvbWx5IHNhbXBsZWQgYXMgY2FuZGlkYXRlcyBhdCBlYWNoIHNwbGl0LiBOb3RlIHRoYXQgdGhlIGRlZmF1bHQgdmFsdWVzIGFyZSBkaWZmZXJlbnQgZm9yIGNsYXNzaWZpY2F0aW9uIChzcXJ0KHApIHdoZXJlIHAgaXMgbnVtYmVyIG9mIHZhcmlhYmxlcyBpbiB4KSBhbmQgcmVncmVzc2lvbiAocC8zKQ0KYmFnLmJvc3Rvbg0KYGBgDQoqKlRlc3Rpbmcgb3VyIE1vZGVsKioNCg0KVGhlIE9PQiBlc3RpbWF0ZSBmb3IgTVNFIGlzIDE0LjA5DQoNCg0KYGBge3J9DQp5aGF0LmJhZyA9IHByZWRpY3QgKGJhZy5ib3N0b24gLCBuZXdkYXRhPUJvc3RvblstdHJhaW4gLF0pDQpnZ3Bsb3QoKSsNCiAgZ2VvbV9wb2ludChhZXMoeCA9IHloYXQuYmFnLCB5ID0gQm9zdG9uWy10cmFpbiwgIm1lZHYiXSkpKw0KICBnZW9tX2FibGluZShjb2xvciA9ICJyZWQiKSsNCiAgeGxhYigiUHJlZGljdGVkIFZhbHVlcyIpKw0KICB5bGFiKCJUcnVlIFZhbHVlcyIpDQpgYGANCg0KDQpgYGB7cn0NCm1lYW4oKHloYXQuYmFnIC1Cb3N0b25bLXRyYWluLCAibWVkdiJdKV4yKQ0KYGBgDQpUaGUgdGVzdCBzZXQgTVNFIGFzc29jaWF0ZWQgd2l0aCB0aGUgYmFnZ2VkIHJlZ3Jlc3Npb24gdHJlZSBpcyAxNC4wOCwgdGhpcyBpcyBhbiBpbXByb3ZlbWVudCBvdmVyIHRoZSB0ZXh0Ym9vayBleGFtcGxlIG9mIGEgc2luZ2xlIG9wdGltYWxseSBwcnVuZWQgdHJlZS4NCg0KYGBge3J9DQpzZXQuc2VlZCgxKQ0KYmFnLmJvc3RvbjIgPSByYW5kb21Gb3Jlc3QobWVkdn4uLCBkYXRhID0gQm9zdG9uLCBzdWJzZXQgPSB0cmFpbiwgbXRyeSA9IDEzLCBpbXBvcnRhbmNlID0gVFJVRSwgbnRyZWUgPSAxMDAwKQ0KeWhhdC5iYWcyID0gcHJlZGljdCAoYmFnLmJvc3RvbjIgLCBuZXdkYXRhPUJvc3RvblstdHJhaW4gLF0pDQptZWFuKCh5aGF0LmJhZzIgLUJvc3RvblstdHJhaW4sICJtZWR2Il0pXjIpDQpgYGANCg0KIyMjIEludGVycHJldGF0aW9uDQoNCioqSXQncyBub3QgZ3JlYXQuKiogV2hlbiB3ZSBiYWcgYSBsYXJnZSBudW1iZXIgb2YgdHJlZXMsIGl0IGlzIG5vIGxvbmdlciBwb3NzaWJsZSB0byByZXByZXNlbnQgdGhlIG1vZGVsIHdpdGggYSBzaW5nbGUgdHJlZSBhbmQgaXQgaXMgbm8gbG9uZ2VyIGNsZWFyIHdoaWNoIHZhcmlhYmxlcyBhcmUgbW9zdCBpbXBvcnRhbnQgdG8gdGhlIHByZWNlZHVyZS4NCg0KKipCYWdnaW5nIGltcHJvdmVzIHRoZSBhY2N1cmFjeSBhdCB0aGUgZXhwZW5zZSBvZiBpbnRlcnByZXRhYmlsaXR5KioNCg0KV2UgZG8gaGF2ZSBzb21lIHRvb2xzIHRvIGlkZW50aWZ5IGltcG9ydGFuY2UgdGhvdWdoLCB3ZSBjYW4gdXNlIHRoZSBSU1MgZm9yIHJlZ3Jlc3Npb24gdHJlZXMgb3IgR2luaSBpbmRleCAoUHJvYmFiaWxpdHkgdGhhdCBhIGZlYXR1cmUgaXMgY2xhc3NpZmllZCBpbmNvcnJlY3RseSB3aGVuIHNlbGVjdGVkIHJhbmRvbWx5KSBmb3IgY2xhc3NpZmljYXRpb24uDQoNCkZvciByZWdyZXNzaW9uIC0gV2UgY2FuIGxvb2sgYXQgdGhlIHRvdGFsIGFtb3VudCB0aGUgUlNTIChTdW0gb2YgU3F1YXJlZCBSZXNpZHVhbHMgaWYgeW91LCBsaWtlIG1lLCBmb3Jnb3QpIGhhcyBkZWNyZWFzZWQgZHVlIHRvIHNwbGl0cyBvdmVyIGEgZ2l2ZW4gcHJlZGljdG9yLiANCg0KRm9yIGNsYXNzaWZpY2F0aW9uIC0gV2UgY2FuIGRvIHRoZSBzYW1lIHdpdGggdGhlIEdpbmkgaW5kZXggbWVhc3VyZS4NCg0KIyMgUmFuZG9tIEZvcmVzdA0KDQpUaGlzIGlzIGFuIGltcHJvdmVtZW50IG92ZXIgYmFnZ2VkIHRyZWVzIGJ5IGRlY29ycmVsYXRpbmcgdGhlIHRyZWVzLiBXZSBzdGlsbCBidWlsZCBtdWx0aXBsZSBkZWNpc2lvbiB0cmVlcyBvbiBib290c3RyYXBwZWQgdHJhaW5pbmcgc2FtcGxlcywgYnV0IGluc3RlYWQgb2YgdXNpbmcgYWxsIHByZWRpY3RvcnMsIHdlIHVzZSBvbmx5IGEgcmFuZG9tIHNhbXBsZSBmcm9tIHRoZSBmdWxsIHNldCBvZiBwcmVkaWN0b3JzLiBUeXBpY2FsbHkgd2UgY2hvb3NlIHRoZSBudW1iZXIgb2YgcHJlZGljdG9ycyB0byBiZSBhcHByb3hpbWF0ZWx5IGVxdWFsIHRvIHRoZSBzcXVhcmUgcm9vdCBvZiB0aGUgdG90YWwgbnVtYmVyIG9mIHByZWRpY3RvcnMuDQoNCldlaXJkIGJ1dCB3b3JrcyEgV2h5IHdvdWxkbid0IHdlIHdhbnQgdGhlIHRyZWVzIHRvIGJlIGJ1aWx0IG9uIGFsbCBhdmFpbGFibGUgZGF0YT8gSG93IGRvZXMgdGhpcyAqZGVjb3JyZWxhdGUqIHRoZSB0cmVlcz8NCg0KRnJvbSB0aGUgdGV4dGJvb2sNCiJTdXBwb3NlIHRoYXQgdGhlcmUgaXMgb25lIHZlcnkgc3Ryb25nIHByZWRpY3RvciBpbiB0aGUgZGF0YSBzZXQsIGFsb25nIHdpdGggYSBudW1iZXIgb2Ygb3RoZXIgbW9kZXJhdGVseSBzdHJvbmcgcHJlZGljdG9ycy4gVGhlbiBpbiB0aGUgY29sbGVjdGlvbiBvZiBiYWdnZWQgdHJlZXMsIG1vc3Qgb3IgYWxsIG9mIHRoZSB0cmVlcyB3aWxsIHVzZSB0aGlzIHN0cm9uZyBwcmVkaWN0b3IgaW4gdGhlIHRvcCBzcGxpdC4gQ29uc2VxdWVudGx5LCBhbGwgb2YgdGhlIGJhZ2dlZCB0cmVlcyB3aWxsIGxvb2sgcXVpdGUgc2ltaWxhciB0byBlYWNoIG90aGVyLiBIZW5jZSB0aGUgcHJlZGljdGlvbnMgZnJvbSB0aGUgYmFnZ2VkIHRyZWVzIHdpbGwgYmUgaGlnaGx5IGNvcnJlbGF0ZWQuIg0KDQpXZSBrbm93IHRoYXQgYXZlcmFnaW5nIG92ZXIgaGlnaGx5IGNvcnJlbGF0ZWQgdmFsdWVzIGRvZXNuJ3QgcmVkdWNlIHRoZSB2YXJpYW5jZSBhcyBtdWNoIGFzIGRvaW5nIHNvIHdpdGggdW5jb3JyZWxhdGVkIHZhbHVlcy4gVGhpcyBtZWFucyB0aGF0IGJhZ2dpbmcgZG9lc24ndCByZWR1Y2UgdGhlIHZhcmlhbmNlIGFzIG11Y2ggYXMgd2Ugd291bGQgbGlrZS4NCg0KUmFuZG9tIGZvcmVzdCBkZWFscyB3aXRoIHRoaXMgYnkgZm9yY2luZyBlYWNoIHRyZWUgdG8gb25seSBjb25zaWRlciBhIHN1YnNldCBvZiB0aGUgcHJlZGljdG9ycy4gSW4gdGhlIHRleHRib29rIGV4YW1wbGUsIHRoaXMgbGVhZHMgdG8gc29tZSB0cmVlcyBub3QgZXZlbiBjb25zaWRlcmluZyB0aGUgc3Ryb25nIHByZWRpY3Rvci4NCg0KKipNYWluIGRpZmZlcmVuY2UgYmV0d2VlbiByYW5kb20gZm9yZXN0IGFuZCBiYWdnaW5nIGlzIHRoZSBjaG9pc2Ugb2YgcHJlZGljdG9yIHN1YnNldCBzaXplKioNCg0KVGhpcyBsZWFkcyB0byBhIHJlZHVjdGlvbiBpbiBib3RoIHRlc3QgZXJyb3IgYW5kIE9PQiBlcnJvciBvdmVyIGJhZ2dpbmcuIEJhc2ljYWxseSB1c2UgcmFuZG9tZm9yZXN0LCBub3QgYmFnZ2luZy4NCg0KKipOb3RlKiogU29tZXRpbWVzIHdlIG1heSB3YW50IHRvIHVzZSBsZXNzIHRoYW4gdGhlIHN1Z2dlc3RlZCBudW1iZXIgb2YgcHJlZGljdG9ycyB3aGVuIHZhcmlhYmxlcyBhcmUgaGlnaGx5IGNvcnJlbGF0ZWQuIFRoZSByYW5kb21Gb3Jlc3QgbGlicmFyeSBpbiBSIGRlZmF1bHRzIHRvIHAvMyBmb3IgcmVncmVzc2lvbiB0cmVlcy4NCg0KIyMjIEFwcGxpY2F0aW9uIG9mIFJhbmRvbWZvcmVzdA0KDQpgYGB7cn0NCnNldC5zZWVkKDEpDQpyZi5ib3N0b249IHJhbmRvbUZvcmVzdChtZWR2IH4gLixkYXRhPUJvc3Rvbiwgc3Vic2V0PXRyYWluLCBtdHJ5PTYsIGltcG9ydGFuY2UgPVRSVUUpDQp5aGF0LnJmID0gcHJlZGljdChyZi5ib3N0b24gLG5ld2RhdGE9Qm9zdG9uWy0gdHJhaW4gLF0pDQptZWFuKCh5aGF0LnJmLUJvc3RvblstdHJhaW4sICJtZWR2Il0pXjIpDQpgYGANCg0KV293ISBMb29rIGF0IGhvdyBtdWNoIGJldHRlciB0aGF0IGlzLiBMZXQncyBzZWUgaWYgd2UgY2FuIHVuZGVyc3RhbmQgd2hhdCBwcmVkaWN0b3JzIGFyZSBpbXBvcnRhbnQuDQoNCmBgYHtyfQ0KaW1wb3J0YW5jZShyZi5ib3N0b24pDQpgYGANCldlIHNlZSB0aGUgJWluY3JlYXNlIGluIE1TRSB3aGljaCBpcyBhIG1lYXN1cmUgb2YgdGhlIGRlY3JlYXNlIGluIGFjY3VyYWN5IGluIHByZWRpY3Rpb24gb24gdGhlIE9PQiBzYW1wbGVzIHdoZW4gYSBnaXZlbiB2YXJpYWJsZSBpcyBleGNsdWRlZC4gDQoNCldlIGFsc28gc2VlIHRoZSB0b3RhbCBkZWNyZWFzZSBpbiBub2RlIGltcHVyaXR5IHRoYXQgcmVzdWx0cyBmcm9tIHNwbGl0cyBvdmVyIHRoYXQgdmFyaWFibGUgKGF2ZXJhZ2VkIG92ZXIgYWxsIHRyZWVzLikgRm9yIHJlZ3Jlc3Npb24gdGhhdCBpcyBtZWFzdXJlZCBvdmVyIFJTUyBhbmQgZm9yIGNsYXNzaWZpY2F0aW9uIGJ5IGRldmlhbmNlLg0KDQpXZSBjYW4gcGxvdCB0aGlzIQ0KDQpgYGB7cn0NCnZhckltcFBsb3QocmYuYm9zdG9uKQ0KYGBgDQoNCiMjIEJvb3N0aW5nDQoNCkJvb3N0aW5nIGlzIGFub3RoZXIgZ2VuZXJhbCBhcHByb2FjaCB3ZSBjYW4gdXNlIHRvIGltcHJvdmUgc3RhdGlzdGljYWwgbGVhcm5pbmcgbWV0aG9kcy4gQm9vc3Rpbmcgd29ya3MgbGlrZSBiYWdnaW5nIGRvZXMgd2l0aCBtdWx0aXBsZSB0cmVlcywgYnV0IGRvZXNuJ3QgdXNlIGJvb3Qgc3RyYXBwaW5nIGFuZCBpbnN0ZWFkIGVhY2ggdHJlZSBpcyBmaXQgb24gYSBtb2RpZmllZCB2ZXJzaW9uIG9mIHRoZSBvcmlnaW5hbCBkYXRhLiBUaGUgbWFpbiBkaWZmZXJlbmNlIGlzIHRoYXQgaW4gYm9vc3RpbmcgKip0cmVlcyBhcmUgZ3Jvd24gc2VxdWVudGlhbGx5IGJhc2VkIG9uIGluZm9ybWF0aW9uIGxlYXJuZWQgaW4gcHJldmlvdXMgdHJlZXMqKg0KDQohW10oYm9vc3RpbmdhbGdvLnBuZykNCg0KIyMjIFdoYXQgaXMgaW50ZXJlc3RpbmcgYWJvdXQgdGhpcz8NCg0K4oCiIFVubGlrZSBmaXR0aW5nIGEgc2luZ2xlIGxhcmdlIGRlY2lzaW9uIHRyZWUgdG8gdGhlIGRhdGEsIHdoaWNoIGFtb3VudHMgdG8gZml0dGluZyB0aGUgZGF0YSBoYXJkIGFuZCBwb3RlbnRpYWxseSBvdmVyZml0dGluZywgdGhlIGJvb3N0aW5nIGFwcHJvYWNoIGluc3RlYWQgbGVhcm5zIHNsb3dseS4gDQoNCuKAoiBHaXZlbiB0aGUgY3VycmVudCBtb2RlbCwgd2UgZml0IGEgZGVjaXNpb24gdHJlZSB0byB0aGUgcmVzaWR1YWxzIGZyb20gdGhlIG1vZGVsLiBXZSB0aGVuIGFkZCB0aGlzIG5ldyBkZWNpc2lvbiB0cmVlIGludG8gdGhlIGZpdHRlZCBmdW5jdGlvbiBpbiBvcmRlciB0byB1cGRhdGUgdGhlIHJlc2lkdWFscy4gDQoNCuKAoiBFYWNoIG9mIHRoZXNlIHRyZWVzIGNhbiBiZSByYXRoZXIgc21hbGwsIHdpdGgganVzdCBhIGZldyB0ZXJtaW5hbCBub2RlcywgZGV0ZXJtaW5lZCBieSB0aGUgcGFyYW1ldGVyIGQgaW4gdGhlIGFsZ29yaXRobS4gDQoNCuKAoiBCeSBmaXR0aW5nIHNtYWxsIHRyZWVzIHRvIHRoZSByZXNpZHVhbHMsIHdlIHNsb3dseSBpbXByb3ZlIGYgaW4gYXJlYXMgd2hlcmUgaXQgZG9lcyBub3QgcGVyZm9ybSB3ZWxsLiBUaGUgc2hyaW5rYWdlIHBhcmFtZXRlciDOuyBzbG93cyB0aGUgcHJvY2VzcyBkb3duIGV2ZW4gZnVydGhlciwgYWxsb3dpbmcgbW9yZSBhbmQgZGlmZmVyZW50IHNoYXBlZCB0cmVlcyB0byBhdHRhY2sgdGhlIHJlc2lkdWFscy4NCg0KIyMjIFR1bmluZyBQYXJhbWV0ZXJzIGZvciBCb29zdGluZw0KDQoxLiBUaGUgbnVtYmVyIG9mIHRyZWVzIEIuIFVubGlrZSBiYWdnaW5nIGFuZCByYW5kb20gZm9yZXN0cywgYm9vc3RpbmcgY2FuIG92ZXJmaXQgaWYgQiBpcyB0b28gbGFyZ2UsIGFsdGhvdWdoIHRoaXMgb3ZlcmZpdHRpbmcgdGVuZHMgdG8gb2NjdXIgc2xvd2x5IGlmIGF0IGFsbC4gV2UgdXNlIGNyb3NzLXZhbGlkYXRpb24gdG8gc2VsZWN0IEIuIA0KDQoyLiBUaGUgc2hyaW5rYWdlIHBhcmFtZXRlciDOuywgYSBzbWFsbCBwb3NpdGl2ZSBudW1iZXIuIFRoaXMgY29udHJvbHMgdGhlIHJhdGUgYXQgd2hpY2ggYm9vc3RpbmcgbGVhcm5zLiBUeXBpY2FsIHZhbHVlcyBhcmUgMC4wMSBvciAwLjAwMSwgYW5kIHRoZSByaWdodCBjaG9pY2UgY2FuIGRlcGVuZCBvbiB0aGUgcHJvYmxlbS4gVmVyeSBzbWFsbCDOuyBjYW4gcmVxdWlyZSB1c2luZyBhIHZlcnkgbGFyZ2UgdmFsdWUgb2YgQiBpbiBvcmRlciB0byBhY2hpZXZlIGdvb2QgcGVyZm9ybWFuY2UuIA0KDQozLiBUaGUgbnVtYmVyIG9mIHNwbGl0cyBkIGluIGVhY2ggdHJlZSwgd2hpY2ggY29udHJvbHMgdGhlIGNvbXBsZXhpdHkgb2YgdGhlIGJvb3N0ZWQgZW5zZW1ibGUuIE9mdGVuIGQgPSAxIHdvcmtzIHdlbGwsIGluIHdoaWNoIGNhc2UgZWFjaCB0cmVlIGlzIGEgc3R1bXAsIGNvbnNpc3Rpbmcgb2YgYSBzaW5nbGUgc3BsaXQgYW5kIHJlc3VsdGluZyBpbiBhbiBhZGRpdGl2ZSBtb2RlbC4gTW9yZSBnZW5lcmFsbHkgZCBpcyB0aGUgaW50ZXJhY3Rpb24gZGVwdGgsIGFuZCBjb250cm9scyB0aGUgaW50ZXJhY3Rpb24gb3JkZXIgb2YgdGhlIGJvb3N0ZWQgbW9kZWwsIHNpbmNlIGQgc3BsaXRzIGNhbiBpbnZvbHZlIGF0IG1vc3QgZCB2YXJpYWJsZXMuDQoNCg0KIyMjIEFwcGxpY2F0aW9uDQoNCmBgYHtyfQ0Kc2V0LnNlZWQoMTIpDQpib29zdC5ib3N0b249Z2JtKG1lZHZ+LixkYXRhPUJvc3Rvblt0cmFpbiAsXSwgZGlzdHJpYnV0aW9uPSJnYXVzc2lhbiIsbi50cmVlcz01MDAwLCBpbnRlcmFjdGlvbi5kZXB0aD00KQ0Kc3VtbWFyeShib29zdC5ib3N0b24pDQpgYGANCg0KQ2xlYXJseSBybSBhbmQgbHN0YXQgYXJlIHRoZSBtb3N0IGluZmx1ZW50aWFsLCBsZXRzIHRha2UgYSBsb29rIGF0IHRoZW0gaW5kaXZpZHVhbGx5DQoNCmBgYHtyfQ0KcGxvdChib29zdC5ib3N0b24gLGk9InJtIikNCmBgYA0KYGBge3J9DQpwbG90KGJvb3N0LmJvc3RvbiAsaT0ibHN0YXQiKQ0KYGBgDQoNCmBgYHtyfQ0KeWhhdC5ib29zdD1wcmVkaWN0IChib29zdC5ib3N0b24gLG5ld2RhdGEgPUJvc3RvblstdHJhaW4gLF0pIywgbi50cmVlcz0/PykNCmBgYA0KDQoNCmBgYHtyfQ0KYmVzdC5pdGVyIDwtIGdibS5wZXJmKGJvb3N0LmJvc3RvbiwgbWV0aG9kID0gIk9PQiIsIHBsb3QgPSBGQUxTRSkNCnByaW50KGJlc3QuaXRlcikNCmBgYA0KDQoNCmBgYHtyfQ0Kc2V0LnNlZWQoMSkNCnloYXQuYm9vc3Q9cHJlZGljdCAoYm9vc3QuYm9zdG9uICxuZXdkYXRhID1Cb3N0b25bLXRyYWluICxdLCBuLnRyZWVzPTEwMykNCm1lYW4oKHloYXQuYm9vc3QtQm9zdG9uWy10cmFpbiwgIm1lZHYiXSleMikNCmBgYA0KTm90IGEgZ3JlYXQgTVNFLCBidXQgc3RpbGwgYmV0dGVyIHRoYW4gYmFnZ2luZy4gTGV0J3MgdHJ5IHRvIHR1bmUgaXQgd2l0aCBsYW1iZGENCg0KDQoNCmBgYHtyfQ0Kc2V0LnNlZWQoMSkNCmJvb3N0LmJvc3RvbjI9Z2JtKG1lZHZ+LixkYXRhPUJvc3Rvblt0cmFpbiAsXSwgZGlzdHJpYnV0aW9uPSJnYXVzc2lhbiIsbi50cmVlcz01MDAwLCBpbnRlcmFjdGlvbi5kZXB0aD01LCBzaHJpbmthZ2UgPS4xKQ0KYmVzdC5pdGVyIDwtIGdibS5wZXJmKGJvb3N0LmJvc3RvbjIsIG1ldGhvZCA9ICJPT0IiLHBsb3QgPSBGQUxTRSkNCnloYXQuYm9vc3QyPXByZWRpY3QgKGJvb3N0LmJvc3RvbjIgLG5ld2RhdGEgPUJvc3RvblstdHJhaW4gLF0sIG4udHJlZXM9YmVzdC5pdGVyKQ0KbWVhbigoeWhhdC5ib29zdDItQm9zdG9uWy10cmFpbiwgIm1lZHYiXSleMikNCmBgYA0KDQoNCg0KQW4gaW1wcm92ZW1lbnQhDQoNCiMjQ2xhc3NpZmljYXRpb24NCg0KYGBge3J9DQpkYXRhID0gcmVhZC5jc3YoIlNvY2lhbF9OZXR3b3JrX0Fkcy5jc3YiKQ0KaGVhZChkYXRhKQ0KYGBgDQoNCmBgYHtyfQ0Kc2V0LnNlZWQoMTIzNCkNCmRhdGEkQWdlPXNjYWxlKGRhdGEkQWdlKQ0KZGF0YSRFc3RpbWF0ZWRTYWxhcnk9c2NhbGUoZGF0YSRFc3RpbWF0ZWRTYWxhcnkpDQp0cmFpbiA9IHNhbXBsZSAoMTpucm93KGRhdGEpLCBucm93KGRhdGEpLzIpDQpjbGFzc2lmaWVyID0gcmFuZG9tRm9yZXN0KGZhY3RvcihQdXJjaGFzZWQpfkVzdGltYXRlZFNhbGFyeSArIEFnZSwgZGF0YSA9IGRhdGEsIHN1YnNldD0gdHJhaW4sIG50cmVlID0gMTApDQp5aGF0ID0gcHJlZGljdChjbGFzc2lmaWVyLCBuZXdkYXRhPWRhdGFbLXRyYWluICxdKQ0KYGBgDQoNCmBgYHtyfQ0KY29uZnVzaW9uX21hdHJpeCA9IHRhYmxlKGRhdGFbLXRyYWluLCA1XSx5aGF0KQ0KY29uZnVzaW9uX21hdHJpeA0KYGBgDQoNCmBgYHtyfQ0KdGVzdCA9IGRhdGFbLXRyYWluLCBdDQpYMSA9IHNlcShtaW4odGVzdCRFc3RpbWF0ZWRTYWxhcnkpIC0gMSwgbWF4KHRlc3QkRXN0aW1hdGVkU2FsYXJ5KSArIDEsIGJ5ID0gMC4xKQ0KWDIgPSBzZXEobWluKHRlc3QkQWdlKSAtIDEsIG1heCh0ZXN0JEFnZSkgKyAxLCBieSA9IDAuMSkNCmdyaWQgPSBleHBhbmQuZ3JpZChYMSxYMikNCmNvbG5hbWVzKGdyaWQpID0gYygiRXN0aW1hdGVkU2FsYXJ5IiwiQWdlIikNCnByb2IgPSBwcmVkaWN0KGNsYXNzaWZpZXIsIHR5cGUgPSAicmVzcG9uc2UiLCBuZXdkYXRhID0gZ3JpZCkNCmdncGxvdCgpKw0KICBnZW9tX3BvaW50KGRhdGEgPSBncmlkLCBhZXMoeD1Fc3RpbWF0ZWRTYWxhcnkseT1BZ2UsIGNvbG9yID0gcHJvYiksIHNpemUgPSAuMSkrDQogIGdlb21fcG9pbnQoYWVzKHg9RXN0aW1hdGVkU2FsYXJ5LCB5ID0gQWdlLCBjb2xvcj0gZmFjdG9yKFB1cmNoYXNlZCkpLCBkYXRhID0gdGVzdCkrDQogIGdlb21fY29udG91cihhZXMoeD1ncmlkJEVzdGltYXRlZFNhbGFyeSwgeSA9IGdyaWQkQWdlLCB6PWFzLm51bWVyaWMocHJvYikpKQ0KYGBgDQoNCg0KIyNIVw0KDQoxKSBSZXBlYXQgdGhlIHByZXZpb3VzIGNsYXNzaWZpY2F0aW9uIGV4YW1wbGUgdXNpbmcgYmFnZ2luZyBhbmQgYm9vc3RpbmcgbWV0aG9kcyBhbmQgY29tbWVudCBvbiBhbnkgZGlmZmVyZW5jZXMgeW91IG9ic2VydmUuDQoNCg0KDQoNCg0KDQoNCg0KDQoNCg0KDQoNCg0K
]]>5376E Week 2 HW2021-06-11T00:00:00+00:002021-06-11T00:00:00+00:00https://www.ndled.us/stats/2021/06/11/5375E-Week-2-HW Week2 HW

Libraries

library(tidyverse)
library(GGally)
library(ISLR)
library(boot)

R for Data Science Problems

7.3.4.2 Explore the distribution of price. Do you discover anything unusual or surprising? (Hint: Carefully think about the binwidth and make sure you try a wide range of values.)

ggplot(data = diamonds)+
  geom_histogram((aes(price)))

Right tailed.

ggplot(data = diamonds)+
  geom_histogram((aes(price)), binwidth = 100)

Why is there a huge gap? What is the cheapest value of diamonds and why are so few made? (326)

7.4.1.1 What happens to missing values in a histogram? What happens to missing values in a bar chart? Why is there a difference?

Bar counts missing values while histogram removes them.In histogram, x value needs to be numeric, this is not the case for Bar as it takes on catagorical values and just treats NA as another value.

7.4.1.2 What does na.rm = TRUE do in mean() and sum()? Calculate the mean and sum without the missing values.

7.5.1.5 Compare and contrast geom_violin() with a facetted geom_histogram(), or a coloured geom_freqpoly(). What are the pros and cons of each method?

ggplot(data = diamonds, mapping = aes(x = price)) + 
  geom_freqpoly(mapping = aes(colour = cut), binwidth = 500)

ggplot(data = diamonds, mapping = aes(x = price)) + 
  geom_histogram(mapping = aes(x = price), binwidth = 100)+
  facet_wrap(~ cut, nrow = 2)

ggplot(data = diamonds, mapping = aes(x = price)) + 
  geom_violin(mapping = aes(x = cut, y = price))

Geom Pros Cons
geom_violin() Easy to compare and no transformation needed Don’t really see any
facetted geom_histogram() Easier to see individual distributions Hard to compare different distributions
colored geom_freqpoly() Easy to compare if we change y to density Hard to see differences when just looking at count

ISLR Problems

4.7.5

We now examine the differences between LDA and QDA.

(a) If the Bayes decision boundary is linear, do we expect LDA or QDA to perform better on the training set? On the test set? LDA on test, QDA on training (b) If the Bayes decision boundary is non-linear, do we expect LDA or QDA to perform better on the training set? On the test set? QDA on both

(c) In general, as the sample size n increases, do we expect the test prediction accuracy of QDA relative to LDA to improve, decline, or be unchanged? Why?

Unchaged, it will depend on the underlying decision boundary.

4.7.6

6. Suppose we collect data for a group of students in a statistics class with variables X1 = hours studied, X2 = undergrad GPA, and Y = receive an A. We fit a logistic regression and produce estimated coefficient

(a) Estimate the probability that a student who studies for 40 h and has an undergrad GPA of 3.5 gets an A in the class.

exp(-6 +40*.05+3.5*1)/(1+exp(-6 +40*.05+3.5*1))
[1] 0.3775407

(b) How many hours would the student in part (a) need to study to have a 50 % chance of getting an A in the class?

exp(-6 +50*.05+3.5*1)/(1+exp(-6 +50*.05+3.5*1))
[1] 0.5

5.4.2 We will now derive the probability that a given observation is part of a bootstrap sample. Suppose that we obtain a bootstrap sample from a set of n observations.

(a) What is the probability that the first bootstrap observation is not the jth observation from the original sample? Justify your answer. 1 - 1/n, there is a 1/n chance of choosing a given observation. (b) What is the probability that the second bootstrap observation is not the jth observation from the original sample? 1 - 1/n (c) Argue that the probability that the jth observation is not in the bootstrap sample is (1 − 1/n)^n. there is a 1-1/n probability of a given sample not being a specific bootstap sample, since there are n bootstrap observations, we can easily find the probability of a given observation not being in the bootstrap sample.

(d) When n = 5, what is the probability that the jth observation is in the bootstrap sample? (1-1/5)^5 is the probability it isn’t in the bootstrap sample, so

1-(1-1/5)^5
[1] 0.67232

(e) When n = 100, what is the probability that the jth observation is in the bootstrap sample?

1-(1-1/100)^100
[1] 0.6339677

5.4.5 5. In Chapter 4, we used logistic regression to predict the probability of default using income and balance on the Default data set. We will now estimate the test error of this logistic regression model using the validation set approach. Do not forget to set a random seed before beginning your analysis.

(a) Fit a logistic regression model that uses income and balance to predict default.

logit = glm(default~income+balance, data = Default, family = binomial)
logit

Call:  glm(formula = default ~ income + balance, family = binomial, 
    data = Default)

Coefficients:
(Intercept)       income      balance  
 -1.154e+01    2.081e-05    5.647e-03  

Degrees of Freedom: 9999 Total (i.e. Null);  9997 Residual
Null Deviance:      2921 
Residual Deviance: 1579     AIC: 1585

(b) Using the validation set approach, estimate the test error of this model. In order to do this, you must perform the following steps: i. Split the sample set into a training set and a validation set.

(c) Repeat the process in (b) three times, using three different splits of the observations into a training set and a validation set. Comment on the results obtained.

(d) Now consider a logistic regression model that predicts the probability of default using income, balance, and a dummy variable for student. Estimate the test error for this model using the validation set approach. Comment on whether or not including a dummy variable for student leads to a reduction in the test error rate.

5.4.6 We continue to consider the use of a logistic regression model to predict the probability of default using income and balance on the Default data set. In particular, we will now compute estimates for the standard errors of the income and balance logistic regression coefficients in two different ways: (1) using the bootstrap, and (2) using the standard formula for computing the standard errors in the glm() function. Do not forget to set a random seed before beginning your analysis.

Default

(a) Using the summary() and glm() functions, determine the estimated standard errors for the coefficients associated with income and balance in a multiple logistic regression model that uses both predictors.

model1 = glm(default~income + balance,data = Default, family = "binomial")
summary(model1)$coefficients[,2]
 (Intercept)       income      balance 
4.347564e-01 4.985167e-06 2.273731e-04

(b) Write a function, boot.fn(), that takes as input the Default data set as well as an index of the observations, and that outputs the coefficient estimates for income and balance in the multiple logistic regression model.

boot.fn = function(data, index){
  model = glm(default~income + balance,data = data[index,], family = "binomial",subset=index)
  return(summary(model)$coefficients[-1,2])
}

boot.fn(Default, 1:10000)
      income      balance 
4.985167e-06 2.273731e-04

(c) Use the boot() function together with your boot.fn() function to estimate the standard errors of the logistic regression coefficients for income and balance.

set.seed(1)
boot(data = Default, statistic = boot.fn, R = 100) #I'm I reading this correctly?

ORDINARY NONPARAMETRIC BOOTSTRAP


Call:
boot(data = Default, statistic = boot.fn, R = 100)


Bootstrap Statistics :
        original       bias     std. error
t1* 4.985167e-06 3.745402e-08 1.972904e-07
t2* 2.273731e-04 1.662875e-06 1.602112e-05

(d) Comment on the estimated standard errors obtained using the glm() function and using your bootstrap function. Extremely similar. Income is the same up to eight decimal places and balance is the same up to 6 decimal places

LS0tDQp0aXRsZTogIldlZWsyIEhXIg0Kb3V0cHV0OiBodG1sX25vdGVib29rDQotLS0NCioqTGlicmFyaWVzKioNCmBgYHtyfQ0KbGlicmFyeSh0aWR5dmVyc2UpDQpsaWJyYXJ5KEdHYWxseSkNCmxpYnJhcnkoSVNMUikNCmxpYnJhcnkoYm9vdCkNCmBgYA0KIyBSIGZvciBEYXRhIFNjaWVuY2UgUHJvYmxlbXMNCg0KKio3LjMuNC4yIEV4cGxvcmUgdGhlIGRpc3RyaWJ1dGlvbiBvZiBwcmljZS4gRG8geW91IGRpc2NvdmVyIGFueXRoaW5nIHVudXN1YWwgb3Igc3VycHJpc2luZz8gKEhpbnQ6IENhcmVmdWxseSB0aGluayBhYm91dCB0aGUgYmlud2lkdGggYW5kIG1ha2Ugc3VyZSB5b3UgdHJ5IGEgd2lkZSByYW5nZSBvZiB2YWx1ZXMuKSoqDQoNCmBgYHtyfQ0KZ2dwbG90KGRhdGEgPSBkaWFtb25kcykrDQogIGdlb21faGlzdG9ncmFtKChhZXMocHJpY2UpKSkNCmBgYA0KDQpSaWdodCB0YWlsZWQuDQoNCmBgYHtyfQ0KZ2dwbG90KGRhdGEgPSBkaWFtb25kcykrDQogIGdlb21faGlzdG9ncmFtKChhZXMocHJpY2UpKSwgYmlud2lkdGggPSAxMDApDQpgYGANCldoeSBpcyB0aGVyZSBhIGh1Z2UgZ2FwPyBXaGF0IGlzIHRoZSBjaGVhcGVzdCB2YWx1ZSBvZiBkaWFtb25kcyBhbmQgd2h5IGFyZSBzbyBmZXcgbWFkZT8gKDMyNikNCg0KKio3LjQuMS4xIFdoYXQgaGFwcGVucyB0byBtaXNzaW5nIHZhbHVlcyBpbiBhIGhpc3RvZ3JhbT8gV2hhdCBoYXBwZW5zIHRvIG1pc3NpbmcgdmFsdWVzIGluIGEgYmFyIGNoYXJ0PyBXaHkgaXMgdGhlcmUgYSBkaWZmZXJlbmNlPyoqDQoNCkJhciBjb3VudHMgbWlzc2luZyB2YWx1ZXMgd2hpbGUgaGlzdG9ncmFtIHJlbW92ZXMgdGhlbS5JbiBoaXN0b2dyYW0sIHggdmFsdWUgbmVlZHMgdG8gYmUgbnVtZXJpYywgdGhpcyBpcyBub3QgdGhlIGNhc2UgZm9yIEJhciBhcyBpdCB0YWtlcyBvbiBjYXRhZ29yaWNhbCB2YWx1ZXMgYW5kIGp1c3QgdHJlYXRzIE5BIGFzIGFub3RoZXIgdmFsdWUuDQoNCioqNy40LjEuMiBXaGF0IGRvZXMgbmEucm0gPSBUUlVFIGRvIGluIG1lYW4oKSBhbmQgc3VtKCk/KioNCkNhbGN1bGF0ZSB0aGUgbWVhbiBhbmQgc3VtIHdpdGhvdXQgdGhlIG1pc3NpbmcgdmFsdWVzLg0KDQoqKjcuNS4xLjUgQ29tcGFyZSBhbmQgY29udHJhc3QgZ2VvbV92aW9saW4oKSB3aXRoIGEgZmFjZXR0ZWQgZ2VvbV9oaXN0b2dyYW0oKSwgb3IgYSBjb2xvdXJlZCBnZW9tX2ZyZXFwb2x5KCkuIFdoYXQgYXJlIHRoZSBwcm9zIGFuZCBjb25zIG9mIGVhY2ggbWV0aG9kPyoqDQoNCg0KYGBge3J9DQpnZ3Bsb3QoZGF0YSA9IGRpYW1vbmRzLCBtYXBwaW5nID0gYWVzKHggPSBwcmljZSkpICsgDQogIGdlb21fZnJlcXBvbHkobWFwcGluZyA9IGFlcyhjb2xvdXIgPSBjdXQpLCBiaW53aWR0aCA9IDUwMCkNCmBgYA0KYGBge3J9DQpnZ3Bsb3QoZGF0YSA9IGRpYW1vbmRzLCBtYXBwaW5nID0gYWVzKHggPSBwcmljZSkpICsgDQogIGdlb21faGlzdG9ncmFtKG1hcHBpbmcgPSBhZXMoeCA9IHByaWNlKSwgYmlud2lkdGggPSAxMDApKw0KICBmYWNldF93cmFwKH4gY3V0LCBucm93ID0gMikNCmBgYA0KYGBge3J9DQpnZ3Bsb3QoZGF0YSA9IGRpYW1vbmRzLCBtYXBwaW5nID0gYWVzKHggPSBwcmljZSkpICsgDQogIGdlb21fdmlvbGluKG1hcHBpbmcgPSBhZXMoeCA9IGN1dCwgeSA9IHByaWNlKSkNCmBgYA0KDQp8IEdlb20gICAgICAgICAgICAgICAgICAgICAgfCBQcm9zICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgfCBDb25zICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICB8DQp8LS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tfC0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tfC0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS18DQp8IGdlb21fdmlvbGluKCkgICAgICAgICAgICAgfCBFYXN5IHRvIGNvbXBhcmUgYW5kIG5vIHRyYW5zZm9ybWF0aW9uIG5lZWRlZCAgfCBEb24ndCByZWFsbHkgc2VlIGFueSAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICB8DQp8IGZhY2V0dGVkIGdlb21faGlzdG9ncmFtKCkgfCBFYXNpZXIgdG8gc2VlIGluZGl2aWR1YWwgZGlzdHJpYnV0aW9ucyAgICAgICAgfCBIYXJkIHRvIGNvbXBhcmUgZGlmZmVyZW50IGRpc3RyaWJ1dGlvbnMgICAgICAgICAgICB8DQp8IGNvbG9yZWQgZ2VvbV9mcmVxcG9seSgpICAgfCBFYXN5IHRvIGNvbXBhcmUgaWYgd2UgY2hhbmdlIHkgdG8gZGVuc2l0eSAgICAgfCBIYXJkIHRvIHNlZSBkaWZmZXJlbmNlcyB3aGVuIGp1c3QgbG9va2luZyBhdCBjb3VudCB8ICAgICAgICAgICAgICAgICAgICAgICANCg0KIyBJU0xSIFByb2JsZW1zDQoNCioqNC43LjUgKioNCg0KKipXZSBub3cgZXhhbWluZSB0aGUgZGlmZmVyZW5jZXMgYmV0d2VlbiBMREEgYW5kIFFEQS4qKg0KDQoqKihhKSBJZiB0aGUgQmF5ZXMgZGVjaXNpb24gYm91bmRhcnkgaXMgbGluZWFyLCBkbyB3ZSBleHBlY3QgTERBIG9yIFFEQSB0byBwZXJmb3JtIGJldHRlciBvbiB0aGUgdHJhaW5pbmcgc2V0PyBPbiB0aGUgdGVzdCBzZXQ/KioNCiBMREEgb24gdGVzdCwgUURBIG9uIHRyYWluaW5nDQoqKihiKSBJZiB0aGUgQmF5ZXMgZGVjaXNpb24gYm91bmRhcnkgaXMgbm9uLWxpbmVhciwgZG8gd2UgZXhwZWN0IExEQSBvciBRREEgdG8gcGVyZm9ybSBiZXR0ZXIgb24gdGhlIHRyYWluaW5nIHNldD8gT24gdGhlIHRlc3Qgc2V0PyoqDQogIFFEQSBvbiBib3RoDQoNCioqKGMpIEluIGdlbmVyYWwsIGFzIHRoZSBzYW1wbGUgc2l6ZSBuIGluY3JlYXNlcywgZG8gd2UgZXhwZWN0IHRoZSB0ZXN0IHByZWRpY3Rpb24gYWNjdXJhY3kgb2YgUURBIHJlbGF0aXZlIHRvIExEQSB0byBpbXByb3ZlLCBkZWNsaW5lLCBvciBiZSB1bmNoYW5nZWQ/IFdoeT8qKiANCg0KVW5jaGFnZWQsIGl0IHdpbGwgZGVwZW5kIG9uIHRoZSB1bmRlcmx5aW5nIGRlY2lzaW9uIGJvdW5kYXJ5Lg0KDQoqKjQuNy42KioNCg0KKio2LiBTdXBwb3NlIHdlIGNvbGxlY3QgZGF0YSBmb3IgYSBncm91cCBvZiBzdHVkZW50cyBpbiBhIHN0YXRpc3RpY3MgY2xhc3Mgd2l0aCB2YXJpYWJsZXMgWDEgPSBob3VycyBzdHVkaWVkLCBYMiA9IHVuZGVyZ3JhZCBHUEEsIGFuZCBZID0gcmVjZWl2ZSBhbiBBLiBXZSBmaXQgYSBsb2dpc3RpYyByZWdyZXNzaW9uIGFuZCBwcm9kdWNlIGVzdGltYXRlZCBjb2VmZmljaWVudCoqDQoNCioqKGEpIEVzdGltYXRlIHRoZSBwcm9iYWJpbGl0eSB0aGF0IGEgc3R1ZGVudCB3aG8gc3R1ZGllcyBmb3IgNDAgaCBhbmQgaGFzIGFuIHVuZGVyZ3JhZCBHUEEgb2YgMy41IGdldHMgYW4gQSBpbiB0aGUgY2xhc3MuKioNCmBgYHtyfQ0KZXhwKC02ICs0MCouMDUrMy41KjEpLygxK2V4cCgtNiArNDAqLjA1KzMuNSoxKSkNCmBgYA0KDQoqKihiKSBIb3cgbWFueSBob3VycyB3b3VsZCB0aGUgc3R1ZGVudCBpbiBwYXJ0IChhKSBuZWVkIHRvIHN0dWR5IHRvIGhhdmUgYSA1MCAlIGNoYW5jZSBvZiBnZXR0aW5nIGFuIEEgaW4gdGhlIGNsYXNzPyoqDQpgYGB7cn0NCmV4cCgtNiArNTAqLjA1KzMuNSoxKS8oMStleHAoLTYgKzUwKi4wNSszLjUqMSkpDQpgYGANCg0KDQoqKjUuNC4yIFdlIHdpbGwgbm93IGRlcml2ZSB0aGUgcHJvYmFiaWxpdHkgdGhhdCBhIGdpdmVuIG9ic2VydmF0aW9uIGlzIHBhcnQgb2YgYSBib290c3RyYXAgc2FtcGxlLiBTdXBwb3NlIHRoYXQgd2Ugb2J0YWluIGEgYm9vdHN0cmFwIHNhbXBsZSBmcm9tIGEgc2V0IG9mIG4gb2JzZXJ2YXRpb25zLiAqKg0KDQoqKihhKSBXaGF0IGlzIHRoZSBwcm9iYWJpbGl0eSB0aGF0IHRoZSBmaXJzdCBib290c3RyYXAgb2JzZXJ2YXRpb24gaXMgbm90IHRoZSBqdGggb2JzZXJ2YXRpb24gZnJvbSB0aGUgb3JpZ2luYWwgc2FtcGxlPyBKdXN0aWZ5IHlvdXIgYW5zd2VyLioqDQoxIC0gMS9uLCB0aGVyZSBpcyBhIDEvbiBjaGFuY2Ugb2YgY2hvb3NpbmcgYSBnaXZlbiBvYnNlcnZhdGlvbi4NCioqKGIpIFdoYXQgaXMgdGhlIHByb2JhYmlsaXR5IHRoYXQgdGhlIHNlY29uZCBib290c3RyYXAgb2JzZXJ2YXRpb24gaXMgbm90IHRoZSBqdGggb2JzZXJ2YXRpb24gZnJvbSB0aGUgb3JpZ2luYWwgc2FtcGxlPyoqDQoxIC0gMS9uDQoqKihjKSBBcmd1ZSB0aGF0IHRoZSBwcm9iYWJpbGl0eSB0aGF0IHRoZSBqdGggb2JzZXJ2YXRpb24gaXMgbm90IGluIHRoZSBib290c3RyYXAgc2FtcGxlIGlzICgxIOKIkiAxL24pXm4uKioNCnRoZXJlIGlzIGEgMS0xL24gcHJvYmFiaWxpdHkgb2YgYSBnaXZlbiBzYW1wbGUgbm90IGJlaW5nIGEgc3BlY2lmaWMgYm9vdHN0YXAgc2FtcGxlLCBzaW5jZSB0aGVyZSBhcmUgbiBib290c3RyYXAgb2JzZXJ2YXRpb25zLCB3ZSBjYW4gZWFzaWx5IGZpbmQgdGhlIHByb2JhYmlsaXR5IG9mIGEgZ2l2ZW4gb2JzZXJ2YXRpb24gbm90IGJlaW5nIGluIHRoZSBib290c3RyYXAgc2FtcGxlLg0KDQoqKihkKSBXaGVuIG4gPSA1LCB3aGF0IGlzIHRoZSBwcm9iYWJpbGl0eSB0aGF0IHRoZSBqdGggb2JzZXJ2YXRpb24gaXMgaW4gdGhlIGJvb3RzdHJhcCBzYW1wbGU/KioNCigxLTEvNSleNSBpcyB0aGUgcHJvYmFiaWxpdHkgaXQgaXNuJ3QgaW4gdGhlIGJvb3RzdHJhcCBzYW1wbGUsIHNvDQoNCmBgYHtyfQ0KMS0oMS0xLzUpXjUNCmBgYA0KDQoqKihlKSBXaGVuIG4gPSAxMDAsIHdoYXQgaXMgdGhlIHByb2JhYmlsaXR5IHRoYXQgdGhlIGp0aCBvYnNlcnZhdGlvbiBpcyBpbiB0aGUgYm9vdHN0cmFwIHNhbXBsZT8qKg0KYGBge3J9DQoxLSgxLTEvMTAwKV4xMDANCmBgYA0KDQoNCioqNS40LjUgNS4gSW4gQ2hhcHRlciA0LCB3ZSB1c2VkIGxvZ2lzdGljIHJlZ3Jlc3Npb24gdG8gcHJlZGljdCB0aGUgcHJvYmFiaWxpdHkgb2YgZGVmYXVsdCB1c2luZyBpbmNvbWUgYW5kIGJhbGFuY2Ugb24gdGhlIERlZmF1bHQgZGF0YSBzZXQuIFdlIHdpbGwgbm93IGVzdGltYXRlIHRoZSB0ZXN0IGVycm9yIG9mIHRoaXMgbG9naXN0aWMgcmVncmVzc2lvbiBtb2RlbCB1c2luZyB0aGUgdmFsaWRhdGlvbiBzZXQgYXBwcm9hY2guIERvIG5vdCBmb3JnZXQgdG8gc2V0IGEgcmFuZG9tIHNlZWQgYmVmb3JlIGJlZ2lubmluZyB5b3VyIGFuYWx5c2lzLioqDQoNCioqKGEpIEZpdCBhIGxvZ2lzdGljIHJlZ3Jlc3Npb24gbW9kZWwgdGhhdCB1c2VzIGluY29tZSBhbmQgYmFsYW5jZSB0byBwcmVkaWN0IGRlZmF1bHQuKioNCg0KYGBge3J9DQpsb2dpdCA9IGdsbShkZWZhdWx0fmluY29tZStiYWxhbmNlLCBkYXRhID0gRGVmYXVsdCwgZmFtaWx5ID0gYmlub21pYWwpDQpsb2dpdA0KYGBgDQoNCg0KKiooYikgVXNpbmcgdGhlIHZhbGlkYXRpb24gc2V0IGFwcHJvYWNoLCBlc3RpbWF0ZSB0aGUgdGVzdCBlcnJvciBvZiB0aGlzIG1vZGVsLiBJbiBvcmRlciB0byBkbyB0aGlzLCB5b3UgbXVzdCBwZXJmb3JtIHRoZSBmb2xsb3dpbmcgc3RlcHM6IGkuIFNwbGl0IHRoZSBzYW1wbGUgc2V0IGludG8gYSB0cmFpbmluZyBzZXQgYW5kIGEgdmFsaWRhdGlvbiBzZXQuKioNCg0KKiooYykgUmVwZWF0IHRoZSBwcm9jZXNzIGluIChiKSB0aHJlZSB0aW1lcywgdXNpbmcgdGhyZWUgZGlmZmVyZW50IHNwbGl0cyBvZiB0aGUgb2JzZXJ2YXRpb25zIGludG8gYSB0cmFpbmluZyBzZXQgYW5kIGEgdmFsaWRhdGlvbiBzZXQuIENvbW1lbnQgb24gdGhlIHJlc3VsdHMgb2J0YWluZWQuKioNCg0KKiooZCkgTm93IGNvbnNpZGVyIGEgbG9naXN0aWMgcmVncmVzc2lvbiBtb2RlbCB0aGF0IHByZWRpY3RzIHRoZSBwcm9iYWJpbGl0eSBvZiBkZWZhdWx0IHVzaW5nIGluY29tZSwgYmFsYW5jZSwgYW5kIGEgZHVtbXkgdmFyaWFibGUgZm9yIHN0dWRlbnQuIEVzdGltYXRlIHRoZSB0ZXN0IGVycm9yIGZvciB0aGlzIG1vZGVsIHVzaW5nIHRoZSB2YWxpZGF0aW9uIHNldCBhcHByb2FjaC4gQ29tbWVudCBvbiB3aGV0aGVyIG9yIG5vdCBpbmNsdWRpbmcgYSBkdW1teSB2YXJpYWJsZSBmb3Igc3R1ZGVudCBsZWFkcyB0byBhIHJlZHVjdGlvbiBpbiB0aGUgdGVzdCBlcnJvciByYXRlLioqDQoNCioqNS40LjYgV2UgY29udGludWUgdG8gY29uc2lkZXIgdGhlIHVzZSBvZiBhIGxvZ2lzdGljIHJlZ3Jlc3Npb24gbW9kZWwgdG8gcHJlZGljdCB0aGUgcHJvYmFiaWxpdHkgb2YgZGVmYXVsdCB1c2luZyBpbmNvbWUgYW5kIGJhbGFuY2Ugb24gdGhlIERlZmF1bHQgZGF0YSBzZXQuIEluIHBhcnRpY3VsYXIsIHdlIHdpbGwgbm93IGNvbXB1dGUgZXN0aW1hdGVzIGZvciB0aGUgc3RhbmRhcmQgZXJyb3JzIG9mIHRoZSBpbmNvbWUgYW5kIGJhbGFuY2UgbG9naXN0aWMgcmVncmVzc2lvbiBjb2VmZmljaWVudHMgaW4gdHdvIGRpZmZlcmVudCB3YXlzOiAoMSkgdXNpbmcgdGhlIGJvb3RzdHJhcCwgYW5kICgyKSB1c2luZyB0aGUgc3RhbmRhcmQgZm9ybXVsYSBmb3IgY29tcHV0aW5nIHRoZSBzdGFuZGFyZCBlcnJvcnMgaW4gdGhlIGdsbSgpIGZ1bmN0aW9uLiBEbyBub3QgZm9yZ2V0IHRvIHNldCBhIHJhbmRvbSBzZWVkIGJlZm9yZSBiZWdpbm5pbmcgeW91ciBhbmFseXNpcy4qKg0KDQpgYGB7cn0NCkRlZmF1bHQNCmBgYA0KDQoNCioqKGEpIFVzaW5nIHRoZSBzdW1tYXJ5KCkgYW5kIGdsbSgpIGZ1bmN0aW9ucywgZGV0ZXJtaW5lIHRoZSBlc3RpbWF0ZWQgc3RhbmRhcmQgZXJyb3JzIGZvciB0aGUgY29lZmZpY2llbnRzIGFzc29jaWF0ZWQgd2l0aCBpbmNvbWUgYW5kIGJhbGFuY2UgaW4gYSBtdWx0aXBsZSBsb2dpc3RpYyByZWdyZXNzaW9uIG1vZGVsIHRoYXQgdXNlcyBib3RoIHByZWRpY3RvcnMuKioNCg0KYGBge3J9DQptb2RlbDEgPSBnbG0oZGVmYXVsdH5pbmNvbWUgKyBiYWxhbmNlLGRhdGEgPSBEZWZhdWx0LCBmYW1pbHkgPSAiYmlub21pYWwiKQ0Kc3VtbWFyeShtb2RlbDEpJGNvZWZmaWNpZW50c1ssMl0NCmBgYA0KDQoNCioqKGIpIFdyaXRlIGEgZnVuY3Rpb24sIGJvb3QuZm4oKSwgdGhhdCB0YWtlcyBhcyBpbnB1dCB0aGUgRGVmYXVsdCBkYXRhIHNldCBhcyB3ZWxsIGFzIGFuIGluZGV4IG9mIHRoZSBvYnNlcnZhdGlvbnMsIGFuZCB0aGF0IG91dHB1dHMgdGhlIGNvZWZmaWNpZW50IGVzdGltYXRlcyBmb3IgaW5jb21lIGFuZCBiYWxhbmNlIGluIHRoZSBtdWx0aXBsZSBsb2dpc3RpYyByZWdyZXNzaW9uIG1vZGVsLioqDQoNCmBgYHtyfQ0KYm9vdC5mbiA9IGZ1bmN0aW9uKGRhdGEsIGluZGV4KXsNCiAgbW9kZWwgPSBnbG0oZGVmYXVsdH5pbmNvbWUgKyBiYWxhbmNlLGRhdGEgPSBkYXRhW2luZGV4LF0sIGZhbWlseSA9ICJiaW5vbWlhbCIsc3Vic2V0PWluZGV4KQ0KICByZXR1cm4oc3VtbWFyeShtb2RlbCkkY29lZmZpY2llbnRzWy0xLDJdKQ0KfQ0KDQpib290LmZuKERlZmF1bHQsIDE6MTAwMDApDQpgYGANCg0KKiooYykgVXNlIHRoZSBib290KCkgZnVuY3Rpb24gdG9nZXRoZXIgd2l0aCB5b3VyIGJvb3QuZm4oKSBmdW5jdGlvbiB0byBlc3RpbWF0ZSB0aGUgc3RhbmRhcmQgZXJyb3JzIG9mIHRoZSBsb2dpc3RpYyByZWdyZXNzaW9uIGNvZWZmaWNpZW50cyBmb3IgaW5jb21lIGFuZCBiYWxhbmNlLioqDQoNCmBgYHtyfQ0Kc2V0LnNlZWQoMSkNCmJvb3QoZGF0YSA9IERlZmF1bHQsIHN0YXRpc3RpYyA9IGJvb3QuZm4sIFIgPSAxMDApICNJJ20gSSByZWFkaW5nIHRoaXMgY29ycmVjdGx5Pw0KYGBgDQoNCg0KKiooZCkgQ29tbWVudCBvbiB0aGUgZXN0aW1hdGVkIHN0YW5kYXJkIGVycm9ycyBvYnRhaW5lZCB1c2luZyB0aGUgZ2xtKCkgZnVuY3Rpb24gYW5kIHVzaW5nIHlvdXIgYm9vdHN0cmFwIGZ1bmN0aW9uLioqDQpFeHRyZW1lbHkgc2ltaWxhci4gSW5jb21lIGlzIHRoZSBzYW1lIHVwIHRvIGVpZ2h0IGRlY2ltYWwgcGxhY2VzIGFuZCBiYWxhbmNlIGlzIHRoZSBzYW1lIHVwIHRvIDYgZGVjaW1hbCBwbGFjZXM=
]]>