ӝੜਅ໵ʢಙౡେֶσβΠϯܕ"*ڭҭݚڀηϯλʔʣ ɹϢʔβͷͨΊͷ ػցֶशνϡʔτϦΞϧ ୈೋ෦ɿ஍ཧۭؒσʔλͷػցֶश΁ͷద༻ ೔ຊ౷ܭֶձୈճय़قूձاըηογϣϯ".#  https://github.com/uribo/240309_jss18tutorial  𝕏 u_ribo

νϡʔτϦΞϧͷ಺༰ ୈҰ෦ʢ෼ʣ ୈೋ෦ʢ෼ʣ ػցֶशͷϫʔΫϑϩʔʹ͍ͭͯ 3ʹΑΔػցֶशͷ࣮ԋ ٳܜʢ෼ʣ ஍ཧۭؒσʔλͷಛ௃ ஍ཧۭؒσʔλʷػցֶशϞσϧ ஍ཧۭؒσʔλΛػցֶशʹ ద༻͢Δࡍͷ՝୊ ۭؒґଘੑ΁ͷ഑ྀ Ϟσϧͷۭؒతͳద༻ൣғ ػցֶशϑϨʔϜϫʔΫͷಋೖ

஍ཧۭؒσʔλ ʷ ػցֶशϞσϧ

஍ཧۭؒσʔλͷಛ௃ ۭؒࣗݾ૬ؔ ۭؒతҟ࣭ੑ ۭؒతʹ͍ۙ؍ଌσʔλ͸ޓ͍ʹྨࣅ͢Δ σʔλͷੑ࣭΍ύλʔϯ͕஍ҬʹΑͬͯҟͳΔ ྫʣ஍Ձ͕ߴ͍σʔλͷपลʹ͸Ͳ͏Α͏ʹ஍Ձ͕ߴ͍σʔλ͕෼෍͢Δ ྫʣ౎ࢢͱ஍ํͷͭͷ஍ҬͰॅ୐Ձ֨ʹӨڹΛ༩͑Δม਺͕ҟͳΔ ɹɹ౎ࢢͰ͸ʮλʔϛφϧӺ͔Βͷۙ͞ʯ ɹɹ஍ํͰ͸ʮ౔஍ͷ޿͞ʯ΍ʮࣗવ؀ڥʯ ͜ΕΒͷಛ௃Λཧղͨ͠͏͑ͰɺϞσϦϯάͷ޻෉ɺ݁Ռͷղऍ͕ٻΊΒΕΔ

ۭؒࣗݾ૬ؔͷྫ ઍ୅ా۠Λத৺ʹਓޱ౰ͨΓ൜ࡑ݅਺͕ߴ͍ ۠֎Ͱ͸ཱ઒ࢢɺ෢ଂ໺ࢢ͋ͨΓ΋ߴ͍

஍ཧۭؒσʔλͱػցֶशͷར༻ ஍ཧۭؒσʔλͷϞσϦϯάͰ͸ɺઢܗؔ܎ΛԾఆͨ͠΋ͷ͕ଟ͍ ؍ଌσʔλɾκʔϯ͕গ਺Ͱ͋ͬͯ΋ਫ਼౓ͷߴ͍݁Ռ͕ಘΒΕΔ ղऍ͕༰қ ར఺ গ਺ͷσʔλʹΑΔֶशͰ͸աֶशΛى͜͠΍͍͢ ܽ఺ ަޓ࡞༻Λଊ͑ʹ͍͘ʢ༧ଌม਺ͷӨڹ͕ಠཱ͍ͯ͠ΔͱԾఆΛஔͨ͘Ίʣ ˠܾఆ໦ͳͲͷඇઢܗɺަޓ࡞༻Λଊ͑΍͍͢χϡʔϥϧωοτϫʔΫͷ׆༻͕ਐΉ ద༻ൣғ͕޿ҬͳϞσϦϯάͷ৔໘Ͱػցֶशख๏͕޿͘ར༻͞ΕΔ   Ӵ੕ը૾ʢଟ࣍ݩ഑ྻʣΛ༻͍ͨϦϞʔτηϯγϯάͷ෼໺Ͱ͸ਂ૚ֶश͕Ұൠతʁ

Ψεڙڅঢ়گͷೋ஋෼ྨϞσϧͷߏங σʔλʲࠃ౔਺஋৘ใʳ౎ಓ෎ݝ஍Ձௐࠪσʔλʢ೥ʣ https://nlftp.mlit.go.jp/ksj/gml/datalist/KsjTmplt-L02-2020.html ࠃ౔ར༻ܭը๏ࢪߦྩʹج͖ͮɺ֤౎ಓ෎ݝ ஌ࣄʹΑͬͯߦΘΕ֤ͨ೥݄೔࣌఺ͷ஍Ձ ௐࠪ݁Ռʹ͍ͭͯɺͦͷج४஍ͷҐஔʢ఺ʣɺ ௐࠪՁ֨ɺར༻ݱگɺ༻్஍Ҭɺ஍ੵ౳Λ੔උ ͨ͠΋ͷ ˠؔ౦஍ํʢ౎ݝʣͷ σʔλΛՃ޻ͯ͠࢖͍·͢ σʔλߏ଄ MQ MBOEQSJDF TVQQMZ

Ψεڙڅঢ়گͷೋ஋෼ྨϞσϧͷߏங lp_supply_sf |> glimpse() #> Rows: 1,812 #> Columns: 9 #> $ price 115000, 61400, 57200, 51600, 177000, 208000, 57600, 68600… #> $ water TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRU… #> $ gas TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, TR… #> $ sewer TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRU… #> $ above_floor 8, 0, 3, 3, 5, 12, 3, 3, 3, 2, 6, 2, 7, 2, 2, 3, 2, 3, 3,… #> $ under_floor 1, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, … #> $ dist_from_st 1300, 900, 270, 2100, 150, 0, 150, 850, 1200, 400, 640, 1… #> $ fire "๷Ր", "४๷", "४๷", "४๷", "๷Ր", "๷Ր", "४๷", "… #> $ geometry POINT (140.4655 36.37854), POINT (140.47 36.3659), …

ۭؒґଘੑ΁ͷ ഑ྀ

ۭؒతͳ෼෍ͷ֬ೝ mapview::mapview(lp_supply_sf, zcol = "gas", alpha.regions = 0.3, cex = 2.6, lwd = 0.4, legend = TRUE)

ۭؒతͳ෼෍ͷ֬ೝ lp_supply_sf |> filter(price > 1000000) |> mapview::mapview(zcol = "price")

ֶशσʔλͷ஍Ҭ֎ʹϞσϧΛద༻͢Δ ࢛ࠃݝͷ౎ಓ෎ݝ஍ՁௐࠪσʔλʢMQ@TVQQMZ@TG@TIJLPLVʣΛ༻ҙ # rf_final_fit… ୈҰ෦Ͱ࠷ޙʹߏஙͨ͠ϞσϧʢRFɺϋΠύϥ୳ࡧɺಛ௃ྔΤϯδχΞϦϯάΛద༻ʣ extract_workflow(rf_final_fit) |> augment(new_data = lp_test) |> brier_class(truth = gas, .pred_FALSE) #> # A tibble: 1 × 3 #> .metric .estimator .estimate #> #> 1 brier_class binary 0.0417 extract_workflow(rf_final_fit) |> # fire͕NAͷ΋ͷΛআ֎ augment(new_data = lp_supply_sf_shikoku |> dplyr::filter(!is.na(fire))) |> brier_class(truth = gas, .pred_FALSE) #> # A tibble: 1 × 3 #> .metric .estimator .estimate #> #> 1 brier_class binary 0.121 Ϟσϧͷ༧ଌਫ਼౓͕௿Լ

ۭؒґଘੑΛߟྀ͠ͳ͍ަࠩݕূ๏ Ͳͷ෼ੳɾධՁσʔλͰ΋஍Ձ͕ߴ͍۠಺ͷσʔλΛؚΉ

ۭؒґଘੑΛߟྀۭͨؒ͠ަࠩݕূ๏ ஍ཧతʹ͍ۙूஂΛϦαϯϓϧσʔλͷධՁσʔλͱ͢Δ

ۭؒґଘੑΛߟྀۭͨؒ͠ަࠩݕূ๏ set.seed(123) lpsp_split <- initial_split(lp_supply_sf, prop = 0.8, strata = gas) lpsp_train <- training(lpsp_split) lpsp_test <- testing(lpsp_split) library(spatialsample) set.seed(123) lpsp_test <- spatial_clustering_cv(lpsp_train, v = 10) spatial_block_cv(lpsp_train, v = 10)

ۭؒґଘੑΛߟྀۭͨؒ͠ަࠩݕূ๏ fit_resamples(rf_wflow, lpsp_folds_cluster, control = lp_ctrl) |> collect_metrics() #> # A tibble: 2 × 6 #> .metric .estimator mean n std_err .config #> #> 1 accuracy binary 0.869 10 0.0368 Preprocessor1_Model1 #> 2 roc_auc binary 0.798 10 0.0313 Preprocessor1_Model1 finalize_workflow(rf_tune_wflow, lp_tune_best_parameter) |> last_fit(lp_split) |> collect_metrics() #> # A tibble: 2 × 4 #> .metric .estimator .estimate .config #> #> 1 accuracy binary 0.950 Preprocessor1_Model1 #> 2 roc_auc binary 0.909 Preprocessor1_Model1 ۭؒґଘੑΛߟྀ͠ͳ͍ަࠩݕূ๏ͰಘͨϦαϯϓϧσʔλ͔ΒಘͨϞσϧͷੑೳ աֶशʁ

\NMSWFSTF^ͷ৔߹ rr_spcv_rf$aggregate(measures = msr("classif.acc")) #> classif.acc #> 0.8751354 rr_spcv_rf$aggregate(measures = msr("classif.sensitivity")) #> classif.sensitivity #> 0.993692 rr_spcv_rf$aggregate(measures = msr("classif.specificity")) #> classif.specificity #> 0.1686585 library(mlr3verse) library(mlr3spatiotempcv) lpsp_task <- as_task_classif_st(lpsp_train, target = "gas", positive = "TRUE") lpsp_folds_mlr <- rsmp("repeated_spcv_coords", folds = 5, repeats = 100) rr_spcv_rf <- resample(task = lpsp_task, learner = lrn("classif.ranger"), resampling = lpsp_folds_mlr)

Ϟσϧͷۭؒత ͳద༻ൣғ

Ϟσϧͷద༻ൣғ "SFBPG"QQMJDBCJMJUZ"0" ༧ଌϞσϧ͕ద༻ՄೳͳۭؒతྖҬΛධՁ͢Δख๏ )BOOB.FZFSBOE&E[FS1FCFTNB .FUIPET&DPM&WPM 7PMVNF *TTVF 1BHFT %0*9 用 色 4QBUJBM$7 3BOEPN$7

Ϟσϧͷద༻ൣғ "SFBPG"QQMJDBCJMJUZ"0" importance <- vip::vi_permute( rf_fit, target = "gas", metric = "accuracy", pred_wrapper = function(object, newdata) { predict(object, new_data = newdata)$.pred_class }, train = lp_train |> select(gas, sewer, price, above_floor, dist_from_st)) importance #> # A tibble: 4 × 2 #> Variable Importance #> #> 1 sewer 0.00621 #> 2 price 0.0242 #> 3 above_floor 0.00483 #> 4 dist_from_st 0.0152 ᶃม਺ॏཁ౓ΛٻΊΔ

Ϟσϧͷద༻ൣғ "SFBPG"QQMJDBCJMJUZ"0" ᶄ"0"ͷࢉग़ lp_aoa <- waywiser::ww_area_of_applicability( f, lp_train |> mutate(gas = as.numeric(gas) - 1, sewer = as.numeric(sewer), fire = as.numeric(as.factor(fire))), lp_test |> mutate(gas = as.numeric(gas) - 1, sewer = as.numeric(sewer), fire = as.numeric(as.factor(fire))), importance = importance ) lp_aoa #> # Predictors: #> 4 #> Area-of-applicability threshold: #> 0.0865665

Ϟσϧͷద༻ൣғ "SFBPG"QQMJDBCJMJUZ"0" ᶄ"0"ͷࢉग़ mapview::mapview(lp_supply_aoa |> filter(aoa == TRUE), col.regions = "gray") + mapview::mapview(lp_supply_aoa |> filter(aoa == FALSE), col.regions = "#FFA500") lp_supply_aoa <- bind_cols( lp_supply_sf |> mutate(gas = as.numeric(gas)-1, sewer = as.numeric(sewer)), predict(lp_aoa, lp_supply_sf |> mutate(gas = as.numeric(gas)-1, sewer = as.numeric(sewer)))) 用 AOA AOA

Ϟσϧͷద༻ൣғ "SFBPG"QQMJDBCJMJUZ"0" ֶशσʔλͷ஍Ҭ֎ʢ࢛ࠃ஍ํͷσʔλʣͰ͸ʁ AOA AOA ˠֶशσʔλͷ஍Ҭʢؔ౦஍ํʣͱ͸ಛ௃ྔͷॏཁ౓͕ҟͳΔ͜ͱΛࣔࠦ

ँࣙ νϡʔτϦΞϧͷ։࠵ػձΛ͍͖ͨͩ·ͨ͠઒࡚ೳయઌੜʢ౷ܭ਺ཧݚڀॴʣ͸͡ Ίɺ೔ຊ౷ܭֶձୈճय़قूձ࣮ߦҕһձͷօ͞·ɺ ΦʔΨφΠβʔΛۈΊͯͩͬͨ͘͞஍ಓਖ਼ߦઌੜʢؔ੢ֶӃେֶʣɺ ຊ೔ࢀՃ͞Εͨօ͞·ʹײँਃ্͛͠·͢ɻ