第6章: forcats & purrr

library(forcats) library(dplyr) # 基本的な因子の作成 satisfaction <- factor(c("満足", "普通", "不満", "満足", "非常に満足", "普通")) levels(satisfaction) # fct_relevel()でレベルの順序を指定 satisfaction_ordered <- fct_relevel(satisfaction, "非常に満足", "満足", "普通", "不満") levels(satisfaction_ordered) # fct_infreq()で頻度順に並び替え satisfaction_freq <- fct_infreq(satisfaction) levels(satisfaction_freq)

# サンプルデータの作成 products <- factor(c("スマートフォン", "タブレット", "ノートPC", "デスクトップPC", "スマートフォン", "その他", "アクセサリ", "タブレット")) # fct_collapse()でカテゴリを統合 products_grouped <- fct_collapse(products, "モバイル機器" = c("スマートフォン", "タブレット"), "PC" = c("ノートPC", "デスクトップPC"), "その他" = c("その他", "アクセサリ") ) table(products_grouped) # fct_recode()で個別にリコード satisfaction_jp <- factor(c("excellent", "good", "fair", "poor")) satisfaction_recoded <- fct_recode(satisfaction_jp, "優秀" = "excellent", "良好" = "good", "普通" = "fair", "不良" = "poor" ) levels(satisfaction_recoded)

library(purrr) # 数値リストの作成 numbers <- list(c(1, 2, 3), c(4, 5, 6), c(7, 8, 9)) # map()で各要素に関数を適用 sums <- map(numbers, sum) str(sums) # map_dbl()で数値ベクトルを返す sums_numeric <- map_dbl(numbers, sum) sums_numeric # map_chr()で文字ベクトルを返す lengths_char <- map_chr(numbers, ~ paste("長さ:", length(.x))) lengths_char # 複雑な関数の適用 stats <- map(numbers, ~ list( mean = mean(.x), sd = sd(.x), range = range(.x) )) stats

library(tidyr) # サンプルの売上データ sales_data <- tibble( store = rep(c("Store_A", "Store_B", "Store_C"), each = 12), month = rep(1:12, 3), sales = c(rnorm(12, 100, 20), rnorm(12, 150, 30), rnorm(12, 80, 15)) ) # 店舗ごとにネスト nested_sales <- sales_data %>% group_by(store) %>% nest() print(nested_sales) # 各店舗の統計量を計算 store_stats <- nested_sales %>% mutate( stats = map(data, ~ list( mean_sales = mean(.x$sales), total_sales = sum(.x$sales), peak_month = .x$month[which.max(.x$sales)] )) ) # 統計情報を展開 store_summary <- store_stats %>% mutate( mean_sales = map_dbl(stats, ~ .x$mean_sales), total_sales = map_dbl(stats, ~ .x$total_sales), peak_month = map_dbl(stats, ~ .x$peak_month) ) %>% select(store, mean_sales, total_sales, peak_month) print(store_summary)

# 顧客満足度調査データの作成 set.seed(123) customer_survey <- tibble( customer_id = 1:1000, age_group = sample(c("18-25", "26-35", "36-45", "46-55", "56+"), 1000, replace = TRUE), satisfaction = sample(c("非常に不満", "不満", "普通", "満足", "非常に満足"), 1000, replace = TRUE, prob = c(0.05, 0.15, 0.3, 0.35, 0.15)), product_type = sample(c("電子機器", "衣料品", "食品", "書籍", "スポーツ用品"), 1000, replace = TRUE) ) # 因子の順序を適切に設定 customer_survey <- customer_survey %>% mutate( age_group = fct_relevel(age_group, "18-25", "26-35", "36-45", "46-55", "56+"), satisfaction = fct_relevel(satisfaction, "非常に不満", "不満", "普通", "満足", "非常に満足") ) # 年代別満足度の集計 age_satisfaction <- customer_survey %>% count(age_group, satisfaction) %>% group_by(age_group) %>% mutate(percentage = n / sum(n) * 100) print(age_satisfaction) # 満足度を3段階に統合 customer_survey_simplified <- customer_survey %>% mutate( satisfaction_simple = fct_collapse(satisfaction, "不満" = c("非常に不満", "不満"), "普通" = "普通", "満足" = c("満足", "非常に満足") ) ) # 製品タイプ別の満足度（簡略版） product_satisfaction <- customer_survey_simplified %>% count(product_type, satisfaction_simple) %>% group_by(product_type) %>% mutate(percentage = round(n / sum(n) * 100, 1)) print(product_satisfaction)

# 複数の月次売上ファイルがあると仮定 # ファイル名のリストを作成 file_names <- paste0("sales_", 2023, "_", sprintf("%02d", 1:12), ".csv") # ダミーデータを作成する関数 create_monthly_data <- function(month) { tibble( month = month, product = sample(c("Product_A", "Product_B", "Product_C"), 100, replace = TRUE), sales = rnorm(100, 1000 + month * 50, 200), region = sample(c("北海道", "関東", "関西", "九州"), 100, replace = TRUE) ) } # map()を使って全月のデータを作成 monthly_data_list <- map(1:12, create_monthly_data) names(monthly_data_list) <- paste0("Month_", 1:12) # 各月の統計を計算 monthly_stats <- map_dfr(monthly_data_list, ~ { .x %>% summarise( total_sales = sum(sales), avg_sales = mean(sales), transactions = n(), unique_products = n_distinct(product) ) }, .id = "month") print(monthly_stats) # 地域別分析を各月に対して実行 regional_analysis <- map(monthly_data_list, ~ { .x %>% group_by(region) %>% summarise( total_sales = sum(sales), avg_sales = mean(sales), transactions = n(), .groups = 'drop' ) }) # 関東地域の月次推移を抽出 kanto_trend <- map_dfr(regional_analysis, ~ { .x %>% filter(region == "関東") }, .id = "month") print(kanto_trend)

# エラーが発生する可能性のある関数 risky_calculation <- function(x) { if (x < 0) { stop("負の値は計算できません") } sqrt(x) + log(x) } # テストデータ（負の値を含む） test_values <- c(4, 9, -2, 16, -5, 25) # safely()でエラーをキャッチ safe_calculation <- safely(risky_calculation) results <- map(test_values, safe_calculation) # 成功した結果のみを抽出 successful_results <- map(results, "result") %>% keep(~ !is.null(.x)) print(successful_results) # エラーメッセージを抽出 error_messages <- map(results, "error") %>% keep(~ !is.null(.x)) print(error_messages) # possibly()でデフォルト値を指定 safe_calc_with_default <- possibly(risky_calculation, otherwise = NA) clean_results <- map_dbl(test_values, safe_calc_with_default) print(clean_results)

# 複数のアンケート調査データを統合分析 set.seed(456) # 複数の調査期間のデータを作成 survey_periods <- c("2023Q1", "2023Q2", "2023Q3", "2023Q4") create_survey_data <- function(period) { tibble( period = period, respondent_id = 1:500, age_group = sample(c("20代", "30代", "40代", "50代", "60代以上"), 500, replace = TRUE), service_satisfaction = sample(c("非常に不満", "不満", "普通", "満足", "非常に満足"), 500, replace = TRUE, prob = c(0.05, 0.1, 0.25, 0.45, 0.15)), price_satisfaction = sample(c("高すぎる", "やや高い", "適正", "やや安い", "安い"), 500, replace = TRUE, prob = c(0.15, 0.25, 0.4, 0.15, 0.05)), recommendation = sample(c("全く推奨しない", "推奨しない", "どちらでもない", "推奨する", "強く推奨する"), 500, replace = TRUE, prob = c(0.05, 0.1, 0.2, 0.5, 0.15)) ) } # 全期間のデータを作成 all_survey_data <- map_dfr(survey_periods, create_survey_data) # 因子の順序を設定 all_survey_data <- all_survey_data %>% mutate( age_group = fct_relevel(age_group, "20代", "30代", "40代", "50代", "60代以上"), service_satisfaction = fct_relevel(service_satisfaction, "非常に不満", "不満", "普通", "満足", "非常に満足"), price_satisfaction = fct_relevel(price_satisfaction, "高すぎる", "やや高い", "適正", "やや安い", "安い"), recommendation = fct_relevel(recommendation, "全く推奨しない", "推奨しない", "どちらでもない", "推奨する", "強く推奨する") ) # 期間別・年代別の詳細分析 period_age_analysis <- all_survey_data %>% group_by(period, age_group) %>% nest() %>% mutate( analysis = map(data, ~ { list( service_pos_rate = mean(.x$service_satisfaction %in% c("満足", "非常に満足")), price_acceptable_rate = mean(.x$price_satisfaction %in% c("適正", "やや安い", "安い")), recommendation_rate = mean(.x$recommendation %in% c("推奨する", "強く推奨する")), sample_size = nrow(.x) ) }) ) # 分析結果を展開 detailed_analysis <- period_age_analysis %>% mutate( service_pos_rate = map_dbl(analysis, ~ .x$service_pos_rate), price_acceptable_rate = map_dbl(analysis, ~ .x$price_acceptable_rate), recommendation_rate = map_dbl(analysis, ~ .x$recommendation_rate), sample_size = map_dbl(analysis, ~ .x$sample_size) ) %>% select(-data, -analysis) %>% arrange(period, age_group) print(detailed_analysis) # 総合満足度スコアの算出 satisfaction_scores <- all_survey_data %>% group_by(period) %>% nest() %>% mutate( overall_score = map_dbl(data, ~ { service_score <- mean(as.numeric(.x$service_satisfaction)) price_score <- mean(as.numeric(.x$price_satisfaction)) recommendation_score <- mean(as.numeric(.x$recommendation)) (service_score + price_score + recommendation_score) / 3 }) ) %>% select(period, overall_score) print(satisfaction_scores)