/ Recent content on Roy Blogdown Hugo -- gohugo.io en-us Thu, 05 Aug 2021 00:00:00 +0000 /2021/08/05/tidy-models/ Thu, 05 Aug 2021 00:00:00 +0000 /2021/08/05/tidy-models/ Exploring machine learning models using the Tidy Models package Following the guidance from https://www.tidymodels.org/start/models/ library(tidymodels) # for the parsnip package, along with the rest of tidymodels library(tidyverse) library(broom.mixed) # for converting Bayesian models to tidy tibbles library(dotwhisker) # for visualizing regression results Reading in the Urchin dataset urchins <- read_csv("https://tidymodels.org/start/models/urchins.csv") |> setNames(c("food_regime", "initial_volume", "width")) |> mutate(food_regime = factor(food_regime, levels = c("Initial", "Low", "High"))) ## ## -- Column specification ------------------------------------------------------------------------------------------------ ## cols( ## TREAT = col_character(), ## IV = col_double(), ## SUTW = col_double() ## ) glimpse(urchins) ## Rows: 72 ## Columns: 3 ## $ food_regime <fct> Initial, Initial, Initial, Initial, Initial, Initial, I~ ## $ initial_volume <dbl> 3. /2021/06/08/election-polling-data/ Tue, 08 Jun 2021 00:00:00 +0000 /2021/06/08/election-polling-data/ /2021/05/17/time-series-forecasting/ Mon, 17 May 2021 00:00:00 +0000 /2021/05/17/time-series-forecasting/ library(crypto) library(RGENERATE) library(quantmod) library(lubridate) library(tseries) library(tidyverse) library(forecast) times <- RGENERATE::generate(FUN = rnorm, n = 1000, K = 3,names = c("asset1")) %>% mutate(price = cumsum(asset1)+300) %>% mutate(day = row_number()) times %>% ggplot(aes(day, price))+ geom_line()+theme_minimal() + geom_smooth(method = 'lm', lty = 2, colour = 'red', se = F)+ labs(title = "Dynamically created time series", subtitle = "Created using the RGENERATE pakage") ARIMA modelling assumptions \[X_t = c + \epsilon_t + \sum_{i=1}^p\beta_iX_{t-i}+\sum_{i=1}^q\theta_i\epsilon_{t-i}\] /2021/05/10/heart-attack-risk-analysis/ Mon, 10 May 2021 00:00:00 +0000 /2021/05/10/heart-attack-risk-analysis/ library(tidyverse) library(readr) library(broom) theme_set(theme_minimal()) heart <- read_csv("heart.csv") The dataset can be found on kaggle glimpse(heart) ## Rows: 303 ## Columns: 14 ## $ age <dbl> 63, 37, 41, 56, 57, 57, 56, 44, 52, 57, 54, 48, 49, 64, 58, 5~ ## $ sex <dbl> 1, 1, 0, 1, 0, 1, 0, 1, 1, 1, 1, 0, 1, 1, 0, 0, 0, 0, 1, 0, 1~ ## $ cp <dbl> 3, 2, 1, 1, 0, 0, 1, 1, 2, 2, 0, 2, 1, 3, 3, 2, 2, 3, 0, 3, 0~ ## $ trtbps <dbl> 145, 130, 130, 120, 120, 140, 140, 120, 172, 150, 140, 130, 1~ ## $ chol <dbl> 233, 250, 204, 236, 354, 192, 294, 263, 199, 168, 239, 275, 2~ ## $ fbs <dbl> 1, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0~ ## $ restecg <dbl> 0, 1, 0, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1, 1, 1, 1~ ## $ thalachh <dbl> 150, 187, 172, 178, 163, 148, 153, 173, 162, 174, 160, 139, 1~ ## $ exng <dbl> 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0~ ## $ oldpeak <dbl> 2. /2021/05/06/netflix-titles/ Thu, 06 May 2021 00:00:00 +0000 /2021/05/06/netflix-titles/ Load the weekly Data Download the weekly data and make available in the tt object. library(lubridate) ## Warning: package 'lubridate' was built under R version 4.0.4 ## ## Attaching package: 'lubridate' ## The following objects are masked from 'package:base': ## ## date, intersect, setdiff, union tt <- tt_load("2021-04-20") ## --- Compiling #TidyTuesday Information for 2021-04-20 ---- ## --- There is 1 file available --- ## --- Starting Download --- ## ## Downloading file 1 of 1: `netflix_titles. /2021/03/23/rcpp-integration/ Tue, 23 Mar 2021 00:00:00 +0000 /2021/03/23/rcpp-integration/ Benchmarking a computationally demanding function in R and C++ The Fibonacci sequence mathematically defined as \[F_n = \begin{cases} n, & n\le 2\\ F_{n-1} + F_{n-2}, & n>2 \end{cases}\] R implementation f <- function(n){ if (n < 2) return(n) return(f(n - 1)+f(n - 2)) } sapply(1:10, f) ## [1] 1 1 2 3 5 8 13 21 34 55 Rscores <- benchmark(f(10),f(15), f(20), f(25), f(30))[,1:4] Rscores ## test replications elapsed relative ## 1 f(10) 100 0. /2021/03/15/visual-network/ Mon, 15 Mar 2021 00:00:00 +0000 /2021/03/15/visual-network/ library(visNetwork) library(widgetframe) ## Loading required package: htmlwidgets Hierarchical network example Using Font Awesome integration nodes <- data.frame(id = 1:7, group = c("A", "A", "A","B","B","B","B") ) edges <- data.frame( from = c(1,2,2,2,3,3), to = c(2,3,4,5,6,7) ) figure <- visNetwork(nodes, edges, width = "100%") %>% visGroups(groupname = "A", shape = "icon", icon = list(code = "f0c0", size = 75)) %>% visGroups(groupname = "B", shape = "icon", icon = list(code = "f007", color = "red")) %>% visEdges(arrows = "from") %>% visHierarchicalLayout() %>% addFontAwesome() htmlwidgets::saveWidget(figure, file = "figure. /2020/12/27/thermal-expansion-calculator-with-rshiny/ Sun, 27 Dec 2020 00:00:00 +0000 /2020/12/27/thermal-expansion-calculator-with-rshiny/ https://Alloys.one A CTE calculator and design hub for high entropy alloys. knitr::include_app(url = "https://alloys.one") /corona/ Fri, 11 Dec 2020 00:00:00 +0000 /corona/ /2020/11/11/scrape/ Wed, 11 Nov 2020 00:00:00 +0000 /2020/11/11/scrape/ test of some sort library(reticulate) library(tidyverse) library(lubridate) import pandas as pd import pprint import requests def collapse_results_by_party(results_by_candidate, candidates): results_by_party = {} for candidate, count in results_by_candidate.items(): party = candidates[candidate]['party'] results_by_party[party] = results_by_party.get(party, 0) + count return results_by_party states = [ 'Alaska', 'Alabama', 'Arkansas', 'Arizona', 'California', 'Colorado', 'Connecticut', 'Delaware', 'Florida', 'Georgia', 'Hawaii', 'Iowa', 'Idaho', 'Illinois', 'Indiana', 'Kansas', 'Kentucky', 'Louisiana', 'Massachusetts', 'Maryland', 'Maine', 'Michigan', 'Minnesota', 'Missouri', 'Mississippi', 'Montana', 'North Carolina', 'North Dakota', 'Nebraska', 'New Hampshire', 'New Jersey', 'New Mexico', 'Nevada', 'New York', 'Ohio', 'Oklahoma', 'Oregon', 'Pennsylvania', 'Rhode Island', 'South Carolina', 'South Dakota', 'Tennessee', 'Texas', 'Utah', 'Virginia', 'Vermont', 'Washington', 'Wisconsin', 'West Virginia', 'Wyoming', ] all_results = {} for state in states: print('Downloading {}'. /2020/10/07/market-basket-analysis/ Wed, 07 Oct 2020 00:00:00 +0000 /2020/10/07/market-basket-analysis/ library(tidyverse) library(arulesViz) library(lubridate) library(arules) library(RColorBrewer) library(stringr) library(tidyr) Data sourced from Kaggle https://www.kaggle.com/heeraldedhia/groceries-dataset?select=Groceries_dataset.csv Association rules \(Rule: X \implies Y\) \[Support = \frac{freq(X, Y)}{N}\] \[Confidence = \frac{freq(X, Y)}{freq(X)}\] \[Lift = \frac{Support}{Supp(X)\times Supp(Y)}\] APRIORI Algorithm transactions <- read.csv(file.path("basket.csv")) df <- transactions %>% group_by(Member_number, Date) %>% summarise(items = str_c(itemDescription, collapse = ",")) %>% mutate(n=str_count(items,",")+1) max(df$n) ## [1] 11 transactions %>% count(itemDescription, sort = TRUE) %>% head(5) ## itemDescription n ## 1 whole milk 2502 ## 2 other vegetables 1898 ## 3 rolls/buns 1716 ## 4 soda 1514 ## 5 yogurt 1334 transactions %>% count(itemDescription, sort = TRUE) %>% tail(5) ## itemDescription n ## 163 toilet cleaner 5 ## 164 bags 4 ## 165 baby cosmetics 3 ## 166 kitchen utensil 1 ## 167 preservation products 1 Utidying the dataset for use with the APRIORI algorithm in the “arules” package. /2020/10/01/energyhhi/ Thu, 01 Oct 2020 00:00:00 +0000 /2020/10/01/energyhhi/ UK energy market competitiveness Herfindahl-Hirschman Index Regulators use the HHI Index using the 50 largest companies in a particular industry to determine if that industry should be considered competitive or as close to being a monopoly. A market with an HHI of less than 1,500 is considered to be a competitive marketplace, an HHI of 1,500 to 2,500 to be a moderately concentrated marketplace, and an HHI of 2,500 or greater to be a highly concentrated marketplace. /2020/10/01/interlayer/ Thu, 01 Oct 2020 00:00:00 +0000 /2020/10/01/interlayer/ library(tidyverse) library(gganimate) library(readxl) interlayer_ <- read_excel(file.path("interlayer.xlsx")) interlayer <- interlayer_ %>% pivot_longer(cols = c(colnames(interlayer_)[2],colnames(interlayer_)[9:15]),names_to = c("composition"),values_to=c("CTE")) new <- interlayer %>% filter(composition %in% c("Zr","Cr")) %>% rename("comp"="composition") p <- interlayer %>% filter(!composition %in% c("Zr","Cr")) %>% ggplot(aes(Temp,CTE,colour = composition))+ geom_text(aes(label = ifelse(Temp == 1600,composition,"")),hjust = 0, nudge_y = 0.2,nudge_x = 20)+ geom_text(data = new,aes(colour = comp,label = ifelse(Temp == 1600,comp,"")),hjust = 0, nudge_y = 0.2,nudge_x = 20)+ theme_minimal()+ labs(title="HEA CTE", x="Temperature (K)", y=expression(paste(alpha, " ppm ", "(",K^-1,")")))+ geom_line(size = 2)+ geom_line(size = 2,data = new,aes(Temp, CTE, colour = comp))+ theme(legend. /2020/08/04/oscillations/ Tue, 04 Aug 2020 00:00:00 +0000 /2020/08/04/oscillations/ library(readxl) library(tidyverse) oscillations_raw <- read_excel("oscillations.xlsx", sheet = 3) osc <- oscillations_raw osc %>% pivot_longer(cols =colnames(osc)[2:5], names_to = "variable", values_to = "value") %>% mutate(group = case_when(str_detect(variable,"PMASS1500") ~ "PMASS1500", TRUE ~ "PMASS500")) %>% ggplot(aes(step, value, colour = variable))+ labs(colour = "")+ facet_grid(~ group) + theme(legend.position = "bottom")+ geom_line() /2020/07/16/climate-change-data/ Thu, 16 Jul 2020 00:00:00 +0000 /2020/07/16/climate-change-data/ Climate change data data sourced from the World Bank using WDI R package api. library(Quandl) ## Loading required package: xts ## Warning: package 'xts' was built under R version 4.0.3 ## Loading required package: zoo ## Warning: package 'zoo' was built under R version 4.0.4 ## ## Attaching package: 'zoo' ## The following objects are masked from 'package:base': ## ## as.Date, as.Date.numeric library(wbstats) ## Warning: package 'wbstats' was built under R version 4. /about/ Sun, 05 Jul 2020 21:48:51 -0700 /about/ Roy Blogdown This site was built using the blogdown package. The theme was forked from @jrutheiser/hugo-lithium-theme and modified by Yihui Xie. /2020/07/03/compositional-analysis/ Fri, 03 Jul 2020 00:00:00 +0000 /2020/07/03/compositional-analysis/ https://doi.org/10.1016/j.dib.2018.11.111 divide01 <- function(x){ return(x/100) } data <- read.csv("hardness.csv") %>% mutate(Al=divide01(Al), Co=divide01(Co), Cr=divide01(Cr), Cu=divide01(Cu), Fe=divide01(Fe), Ni=divide01(Ni)) data_ordered <- read.csv("hardness.csv") %>% mutate(Al=divide01(Al), Co=divide01(Co), Cr=divide01(Cr), Cu=divide01(Cu), Fe=divide01(Fe), Ni=divide01(Ni)) %>% arrange(desc(hardness)) closed <- clo(data, parts = 1:6,total=100) cx <- acomp(data, c("Al","Co","Cr")) plot(cx) xc <- acomp(data, c("Al","Co","Cr","Cu","Fe","Ni")) xc_ordered <- acomp(data_ordered, c("Al","Co","Cr","Cu","Fe","Ni")) plot(xc) barplot.acomp(xc) Order of hardness desc barplot.acomp(xc_ordered) Possibly drop copper and nickel library(httr) raw_dd <- read. /2020/07/01/bbc-style-ggplot/ Wed, 01 Jul 2020 00:00:00 +0000 /2020/07/01/bbc-style-ggplot/ library(tidyverse) #setwd("~/University/R/election2019") library(readr) election <- read_csv("HoC-2019GE-results-by-constituency.csv") %>% mutate(con_p=con/valid_votes, lab_p=lab/valid_votes, brexit_p=brexit/valid_votes, ld_p=ld/valid_votes, snp_p=snp/valid_votes) Voting mix of the most populated constituencies party_colours <- c("purple", "dodgerblue", "red","orange","yellow") election %>% arrange(desc(valid_votes)) %>% mutate(constituency_name=fct_reorder(constituency_name,con_p)) %>% head(30) %>% gather(key="Party", value="Number", con, lab, ld, snp, brexit) %>% ggplot(aes(constituency_name,Number,fill=Party))+ geom_col()+ scale_fill_manual(values=party_colours)+ coord_flip()+ bbc_style() Voting mix of the least populated constituencies election %>% arrange(valid_votes) %>% mutate(constituency_name=fct_reorder(constituency_name,valid_votes)) %>% head(30) %>% gather(key="Party", value="Number", con, lab, ld, snp, brexit) %>% ggplot(aes(constituency_name,Number,fill=Party))+ geom_col()+ scale_fill_manual(values=party_colours)+ coord_flip()+ bbc_style() Where are the Conservative strongholds? /2020/07/01/recent-grads/ Wed, 01 Jul 2020 00:00:00 +0000 /2020/07/01/recent-grads/ Exploatory data analysis majors_processed %>% count(Major_category, sort = T) ## # A tibble: 16 x 2 ## Major_category n ## <chr> <int> ## 1 Engineering 29 ## 2 Education 16 ## 3 Humanities & Liberal Arts 15 ## 4 Biology & Life Science 14 ## 5 Business 13 ## 6 Health 12 ## 7 Computers & Mathematics 11 ## 8 Agriculture & Natural Resources 10 ## 9 Physical Sciences 10 ## 10 Psychology & Social Work 9 ## 11 Social Science 9 ## 12 Arts 8 ## 13 Industrial Arts & Consumer Services 7 ## 14 Law & Public Policy 5 ## 15 Communications & Journalism 4 ## 16 Interdisciplinary 1 by_major_category <- majors_processed %>% filter(!