第 5 章 Programming

5.1 Pipe

範例1
threeHeigths <- c(Gary=178, John=182, Cam=175)

找出身高最高的人:

  • 先排序由大到小,

  • 接著取出第一個位置的人名

寫法一

# 先排序由大到小,
sort(threeHeigths, decreasing=T) -> sorted_heights

# 把排好的人名取出
names(sorted_heights) -> sorted_persons

# 接著取出第一個位置的人名
sorted_persons[[1]] -> highestPerson

寫法二 有些同學會寫成

names(sort(threeHeigths, decreasing = T))[[1]] -> highestPerson

寫法一可看出清楚的思路由左到右很符合人類寫作習慣,但會創出中間物件(sorted_heights),如果步驟一多會出現很多中間物件。 寫法二不會有中間物件,卻很不直覺

library(magrittr)

可將寫法一變成串接無中間物件的方式:

sort(threeHeigths, decreasing=T) %>% 
names(.) %>%
.[[1]] -> highestPerson
  • -> 中間物件 換成%>%

  • 再把其他有用到中間物件的位置換成.

這樣概念就叫pipe operation.

5.1.1 原則

Pipe原則:

f(w) -> x
g(x) -> y
h(y) -> z

可寫成

f(w) %>%
  g(.) %>% 
  h(.) -> z

你也可以把w提出來。(想成是透過一個identity function I(.) 得到I(w)值才接到f(.)裡。)

w %>%
  f(.) %>%
  g(.) %>%
  h(.) -> z

%>% 把左邊產生的output,接過去成為下一段函數的input

範例2
# 由cities創出每個元素對應的北部、東部、中部region factor
cities <- factor(c("台北","花蓮","台東","台中"))
levels(cities)
region <- cities

# 以下為一連串的pipe operation
levels(region) -> currentLevels
str_replace(currentLevels,"台北","北部") -> currentLevels1
str_replace(currentLevels1,"花蓮|台東","東部") -> currentLevels2
str_replace(currentLevels2,"台中","中部") -> regionLevels
regionLevels -> levels(region)
levels(region) %>% 
  str_replace(.,"台北","北部") %>%
  str_replace(.,"花蓮|台東","東部") %>%
  str_replace(.,"台中","中部") ->
  levels(region)

5.1.2 元素粹取

其實元素粹取符號$,[],[[]]也是函數, 要被取出元素的物件是第一個input,而取元素的位置資訊則是第二個input。

example$name

example是第一個input,而name是第二個input。

num <- c(2,97,22,15,7)

# 選出大於50的數字
(num > 50) -> pick_big
num[pick_big]
(num > 50) %>%
  num[.]

5.1.3 執行順序

R在面對pipe時會先把pipe走完最後才去做值assign給最後物件的動作,例如:

threeHeights %>%
  .sort(., decreasing=T) %>%
  names(.) %>%
  .[[1]] -> highestPerson

pipe部份為

.sort(threeHeigths, decreasing=T) %>%
names(.) %>%
.[[1]]

最後才去做值assign給最後物件的動作,(即-><-最後進行),所以上面也可以使用左箭頭成為

highestPerson <- 
  threeHeights %>%
  .sort(., decreasing=T) %>%
  names(.) %>%
  .[[1]]

5.1.4 .省略原則

若代表中間物件的.在函數的「第一位」則.*可省略不寫,連它後面的,也去掉。小心若不在第一位則不可做省略.動作。

levels(region) %>%
  str_replace(.,"台北","北部") %>%
  str_replace(.,"花蓮|台東","東部") %>%
  str_replace(.,"台中","中部") ->
  levels(region)

可改成

levels(region) %>% 
  str_replace("台北","北部") %>%
  str_replace("花蓮|台東","東部") %>%
  str_replace("台中","中部") -> 
  levels(region)

要小心%>%是將左邊output放到右邊函數,這裡的右邊函數指的是最外圍的函數:

# 資料
population <- c(`cityA`=500,`cityB`=1500, `cityC`=399)
cities <- c("cityA","cityA","cityB","cityB","cityC")

# 分析步驟
names(sort(population)) -> setLevels
factor(cities, levels = setLevels) -> cities 

分析步驟你可能會寫

population %>% 
  names(sort(.)) %>%
  factor(cities, levels=.) -> cities

會有錯誤源自於

population %>% names(sort(.))

%>%是把population放到names()的input裡,而非sort(),但names()的input位置已被sort佔走。要改成

population %>%
  sort() %>%
  names() %>%
  factor(cities, levels=.) -> cities

5.1.5 串接非單純函數程序

若遇到pipe 串接的下一段並不是單純的函數的話,可以用{}把此段內容括起來並把中間物件要放的位置換成.

範例3
dataList <- list(
  num=c(2,97,22,15,7),
  chr=c("2","97","22","15","7")
)

找出dataList中元素class為numeric裡那些大於50的數字

map(dataList, is.numeric) -> results
unlist(results) -> pick_numeric

dataList[pick_numeric] -> num_element
(num_element[[1]] > 50) -> pick_big
num_element[[1]][pick_big] -> bigNumber
map(dataList, is.numeric) %>%
unlist(.) %>%

dataList[.] %>%
{(.[[1]] > 50)} %>%
num_element[[1]][.] -> bigNumber
5.1.5.0.0.1 範例4
population %>% 
  names(sort(.)) %>%
  factor(cities, levels=.) -> cities
population %>% 
  {names(sort(.))} %>%
  factor(cities, levels=.) -> cities

5.1.6 綜合練習

jsonlite::fromJSON("https://od.cdc.gov.tw/eic/Day_Confirmation_Age_County_Gender_19CoV.json") -> covid19

jsonlite::fromJSON(
  "https://www.dropbox.com/s/jckqryeh5zeat5w/regionPopulation.json?dl=1"
) -> population
unlist(population) -> population

下面程式碼來自4.7節示範如何依人口大小排序設資料縣市factor的levels順序。請以pipe operator改寫它,能串得越多句程式碼越好。

covid19$縣市 <- factor(covid19$縣市)

levels(covid19$縣市) -> levelsInData
population[levelsInData] -> population

population <- sort(population, decreasing=T)
population

newLevels <- names(population)
newLevels

covid19$縣市 <-
  factor(
    covid19$縣市, levels=newLevels
  )

levels(covid19$縣市)

5.2 Function

用來執行一連串有固定SOP(流程)的動作

5.2.1 需求函數

\[q_d=10-5p\]

# p=1.2的需求量
p=1.2
qd <- 10-5*p # 小心是5*p, 不能寫5p
# p=1.3的需求量
p=1.3
qd <- 10-5*p
# p=1.4的需求量
p=1.4
qd <- 10-5*p

會變動的步驟:

  • p=1.2, p=1.3, p=1.4

不會變動的步驟:

  • qd <- 10-5*p

函數定義

demand <- # 創造一個物件叫demand
  function(p){ # 定義這個物件為函數
    q_d <- 10-5*p # 小心是5*p, 不能寫5p
  }
# p=1.2的需求量
demand(1.2) 
# p=1.3的需求量
demand(1.3)
# p=1.4的需求量
demand(1.4)

return

demand_return <- 
  function(p){
    q_d <- 10-5*p
    return(q_d)
  }
# 印在螢幕,但Global Environment並不會有q_d
demand_return(1.2)
## [1] 4

最近一步會使用到電腦記憶體的運算值會暫時記在:

.Last.value
# 要長久存在Global Environment要指定物件名稱(不要求與q_d同名)
demand_return(1.2) -> q_d1.2

當function有return時,

demand_return(1.2) # 相當於
4
## [1] 4
## [1] 4
demand_return(1.2) -> q_d1.2 # 相當於
4 -> q_d1.2
  • return(q_d)只會回傳q_d的「值」但不會回傳整個q_d物件在global environment裡。

  • 實際上,{...}裡所創造的物件都只是「暫時的」且「不放在global environment」,函數運作完就刪除,所以global environment裡就算有同名物件,也不會因函數運作而被不小心更動。

q_d <- 5
demand_return(p=1.2)

print(q_d)

請寫下供給函數: \[q_s=0+2p\]

5.2.2 今日天氣

住三峽的小雯問:“Silly,今天天氣如何?”

Silly需要知道什麼:

  • 日期、地點
dateInput <- today()
locationInput <- "新北市"

Silly找答案的策略:

  • 政府開放資料平台:
jsonlite::fromJSON("https://opendata.cwb.gov.tw/fileapi/v1/opendataapi/F-C0032-001?Authorization=rdec-key-123-45678-011121314&format=JSON") ->
  weather_next36hours
  • 給定日期,地點找出預報資訊
# 找出符合地點的天氣資訊:weatherAtLocation
(weather_next36hours$cwbopendata$dataset$location$locationName == locationInput) -> pick_location # 可挑出locationInput的「要/不要」向量

weather_next36hours$cwbopendata$dataset$location$weatherElement[pick_location][[1]] -> weatherAtLocation

# 在weatherAtLocation找出符合時間的天氣資訊

(weatherAtLocation$elementName=="MaxT") ->
  pick_MaxT
(weatherAtLocation$elementName=="MinT") ->
  pick_MinT
weatherAtLocation$time[pick_MaxT][[1]]$parameter$parameterName[[1]] -> maxT
weatherAtLocation$time[pick_MinT][[1]]$parameter$parameterName[[1]] -> minT

glue::glue("{locationInput} {dateInput} 氣溫,最高{maxT}度,最低{minT}度。")

打造Silly天氣預報機器人:

askSilly_weather <- function(locationInput,dateInput){
  jsonlite::fromJSON("https://opendata.cwb.gov.tw/fileapi/v1/opendataapi/F-C0032-001?Authorization=rdec-key-123-45678-011121314&format=JSON") ->
  weather_next36hours
  
  (weather_next36hours$cwbopendata$dataset$location$locationName == locationInput) -> pick_location
  
  weather_next36hours$cwbopendata$dataset$location$weatherElement[pick_location][[1]] -> weatherAtLocation
  (weatherAtLocation$elementName=="MaxT") ->
    pick_MaxT
  (weatherAtLocation$elementName=="MinT") ->
    pick_MinT
  weatherAtLocation$time[pick_MaxT][[1]]$parameter$parameterName[[1]] -> maxT
  weatherAtLocation$time[pick_MinT][[1]]$parameter$parameterName[[1]] -> minT
  
  glue::glue("{locationInput} {dateInput} 氣溫,最高{maxT}度,最低{minT}度。")
}
askSilly_weather("臺中市",today())
askSilly_weather("花蓮縣",today())

打造一個國際時間轉換機器人叫what_time_it_is,使用方式如:

what_time_it_is("Europe/Paris")

它會依照你電腦目前時間, 即輸入now()得到的時間,去告訴你現在巴黎幾點。

5.2.3 函數的組成

class(demand_return)
# 查詢函數formals arguments要求
formals(askSilly_weather)
## $locationInput
## 
## 
## $dateInput
# 查詢函數主體
body(askSilly_weather)
## {
##     weather_next36hours <- jsonlite::fromJSON("https://opendata.cwb.gov.tw/fileapi/v1/opendataapi/F-C0032-001?Authorization=rdec-key-123-45678-011121314&format=JSON")
##     pick_location <- (weather_next36hours$cwbopendata$dataset$location$locationName == 
##         locationInput)
##     weatherAtLocation <- weather_next36hours$cwbopendata$dataset$location$weatherElement[pick_location][[1]]
##     pick_MaxT <- (weatherAtLocation$elementName == "MaxT")
##     pick_MinT <- (weatherAtLocation$elementName == "MinT")
##     maxT <- weatherAtLocation$time[pick_MaxT][[1]]$parameter$parameterName[[1]]
##     minT <- weatherAtLocation$time[pick_MinT][[1]]$parameter$parameterName[[1]]
##     glue::glue("{locationInput} {dateInput} 氣溫,最高{maxT}度,最低{minT}度。")
## }

函數可以存在list裡

learning_topics <- 
  list(
    subject="函數",
    date=lubridate::ymd("2020-06-03"),
    functionsCreated=list(
      demand=demand_return # 等號右邊是呼叫demand_return的定義值,也就是function(...){...}值定義本身。
    )
  )
learning_topics$functionsCreated$demand(1.2)

其實幾乎所有的物件不管什麼class都可以存在list裡,很威吧!

5.2.4 Environment

typeof(demand_return)
## [1] "closure"

function本身的運作並不能只靠它的定義值function(...){...},還要有適當的環境(environment)條件才能生存。若物件的生存運作需要有適當的環境,表示電腦要存這個物件時還需要包含(enclose)它的(生存)環境一起存。這種儲存型態叫closure(閉包)。

# 查詢函數執行所要求環境
environment(demand_return)
## <environment: R_GlobalEnv>
# 若函數執行需要Global environment已存在某些物件,查詢需要哪些物件
codetools::findGlobals(demand_return)
## [1] "-"      "{"      "*"      "<-"     "return"
intercept <- 10
slope <- -5
myDemand <- function(p){
  q_d <- intercept + slope*p
  return(q_d)
}
environment(demand_return)
environment(myDemand)
codetools::findGlobals(demand_return)
codetools::findGlobals(myDemand) 

# myDemand對Global environment的要求多了intercept及slope
# 移除global environment裡的intercept及slope
rm(intercept, slope)
demand_return(1.2) # 維持正常運作
myDemand(1.2) # 無法運作

myDemand的運作需要global environment裡的intercept, slope物件。這表示

  • 沒有intercept, slope在global environment裡它無法運作。

  • global environment裡的intercept, slope值若有改變,它的運作結果也會不同。(這種「要運作才去呼叫值」的特性叫Lazy evaluation,惰性求值)

intercept <- 10
slope <- -5
myDemand(1.2)
slope <- -1
myDemand(1.2)
intercept <- 5
slope <- -1.2
myDemand(1.2)

5.2.5 預設值

函數lazy evaluation的特性,讓函數的運作:

  • 具有隨時可改變運作狀態的彈性; 但

  • 該工具若落在電腦知識不足的使用者手上會有誤動global environment而產生運作錯誤的危機。

myDemand2 <- function(p, intercept=10, slope=-5){
  q_d <- intercept + slope*p
  return(q_d)
}
environment(myDemand2)
findGlobals(myDemand2) # 不依靠global env裡的intercept/slope
myDemand2(1.2)
myDemand2(1.2, slope=-1)
myDemand2(1.2, intercept=5, slope=-1.2)

預設值是「平常不需要動到的彈性arguments」,習慣上定義時最好放在arguments的最後面。

5.2.6 綜合練習

以下程式只要更動route的值就會回傳該公車目前到站預估時間estimatedArrivalTime及它的路線資訊routeInfo(兩者皆設定回傳30筆資料為上限):

library(httr)
library(magrittr)
route <- "916"

GET(glue::glue("https://ptx.transportdata.tw/MOTC/v2/Bus/EstimatedTimeOfArrival/City/NewTaipei/{route}?$top=30&$format=JSON")) %>%
  content -> estimatedArrivalTime

GET(glue::glue("https://ptx.transportdata.tw/MOTC/v2/Bus/Route/City/NewTaipei/{route}?$top=30&$format=JSON")) %>%
  content -> routeInfo

打造公車到站預報機器人when_busArrives:

when_busArrives("916","臺北大學正門")
when_busArrives("939","學勤路")

5.3 Conditional Execution

5.3.1 if

  • 用在「某個條件符合才執行」的狀況。
if(condition){
  Body for TRUE
  }
  • condition: 它是個「是/否」問句。 (使用條件判斷來產生答案T/F,是個logical。)

判斷學號輸入正確與否

readline()在Rmd裡只有當它單獨執行時才能正常運作,因為readline是個即時互動(interactive)函數,Rmd不是個即時互動環境。

或使用rstudioapi::showPrompt()則可使用於非interactive的環境。

# 先執行此行輸入學號
readline(prompt = "請輸入你的學號") -> studentId 

# readline一行也可改用以下取代。
# rstudioapi::showPrompt(title="學號驗證",message="請輸入你的學號") -> studentId


# 之後才執行以下程式
if(
  str_detect(studentId,'^[43](1[01][0-9]|9[0-9])[0-9]{5}$',negate=T) # condition: 是否輸入學號正確?
) {
  warning("你所輸入的學號不正確")
}

確認使用者有安裝需要套件

if(!require(lubridate)){ # condition: 是否「沒安裝lubridate」?
  install.packages("lubridate")
}
lubridate::ymd_hms("2020-07-01 13:00:00 GMT")
圖示if流程

一節,我們可以把它形成一個
twDate <-  c("民國108年12月5日","民國98年10月5日")

library(stringr)
# 準備regex: 
## 取出:「前有」民國,「後有」年的「數字」「們」
## "(?<={A_regex}){target_regex}(?={B_regex})"

target_regex <- "[0-9]+"
A_regex <- "民國"
B_regex <- "年"

regex_pattern <- glue::glue(
  "(?<={A_regex}){target_regex}(?={B_regex})"
  )

print(regex_pattern)

## 如果同學已經很熟就可以直接寫
regex_pattern <-
  "(?<=民國)[0-9]+(?=年)"

# 取出民國年,計算西元年
year <- 
  str_extract(
    twDate,
    regex_pattern)
westernYear <- as.integer(year)+1911

# 替換民國xx年的xx成西元年數字
str_replace(
  twDate,
  regex_pattern,  # 要換掉的文字
  as.character(westernYear) # 要替換的內容
) -> twDate_reformat
print(twDate_reformat)


lubridate::ymd(twDate_reformat)

convert_TaiwanDate2WesternDate()函數:

convert_TaiwanDate2WesternDate <- function(twDate){
  library(stringr)
  regex_pattern <-
    "(?<=民國)[0-9]+(?=年)"
  
  # 取出民國年,計算西元年
  year <- 
    str_extract(
      twDate,
      regex_pattern)
  westernYear <- as.integer(year)+1911
  
  # 替換民國xx年的xx成西元年數字
  str_replace(
    twDate,
    regex_pattern,  # 要換掉的文字
    as.character(westernYear) # 要替換的內容
  ) -> twDate_reformat
  
  lubridate::ymd(twDate_reformat) -> westernDate
  return(westernDate)
}

twDate <-  c("民國108年12月5日","民國98年10月5日")
convert_TaiwanDate2WesternDate(twDate)

這函數需要stringr及lubridate

convert_TaiwanDate2WesternDate <- function(twDate){
  
  if(!require("stringr")){
    install.packages("stringr")
  }
  if(!require("lubridate")){
    install.packages("lubridate")
  }
  
  library(stringr)
  regex_pattern <-
    "(?<=民國)[0-9]+(?=年)"
  
  # 取出民國年,計算西元年
  year <- 
    str_extract(
      twDate,
      regex_pattern)
  westernYear <- as.integer(year)+1911
  
  # 替換民國xx年的xx成西元年數字
  str_replace(
    twDate,
    regex_pattern,  # 要換掉的文字
    as.character(westernYear) # 要替換的內容
  ) -> twDate_reformat
  
  lubridate::ymd(twDate_reformat) -> westernDate
  return(westernDate)
}
  1. 寫一個check_package(pkgName)函數,它會檢查使用者是否有安裝pkgName值(class character,length=1)的套件,如果沒有就安裝
# 測試
check_package("clipr")
check_package("SOAR")
  1. check_package()一次只能偵測一個套件是否有安裝。寫一個check_packages(pkgNames) (packages是複數),它以給pkgNames input, pkgNames為class character, length任意。
# 測試
check_packages(c("clipr","SOAR"))
  1. 將convert_TaiwanDate2WesternDate的body有關套件檢查的部份改成你設計的check_package/check_packages。
先前的,如果使用者
askSilly_weather <- function(locationInput,dateInput){
  jsonlite::fromJSON("https://opendata.cwb.gov.tw/fileapi/v1/opendataapi/F-C0032-001?Authorization=rdec-key-123-45678-011121314&format=JSON") ->
  weather_next36hours
  
  (weather_next36hours$cwbopendata$dataset$location$locationName == locationInput) -> pick_location
  
  weather_next36hours$cwbopendata$dataset$location$weatherElement[pick_location][[1]] -> weatherAtLocation
  (weatherAtLocation$elementName=="MaxT") ->
    pick_MaxT
  (weatherAtLocation$elementName=="MinT") ->
    pick_MinT
  weatherAtLocation$time[pick_MaxT][[1]]$parameter$parameterName[[1]] -> maxT
  weatherAtLocation$time[pick_MinT][[1]]$parameter$parameterName[[1]] -> minT
  
  glue::glue("{locationInput} {dateInput} 氣溫,最高{maxT}度,最低{minT}度。")
}
  • 沒有安裝jsonlite;或

  • 縣市裡的「臺」使用簡體「台」

都會產生錯誤訊息。請修改askSilly_weather讓使用者不關有沒有安裝jsonlite或使用簡體「台」都沒問題。


不重覆下載

# 檢視步驟耗時elapse time
system.time(
  jsonlite::fromJSON("https://opendata.cwb.gov.tw/fileapi/v1/opendataapi/F-C0032-001?Authorization=rdec-key-123-45678-011121314&format=JSON") ->
  weather_next36hours
)
if(!exists("weather_next36hours")){
    jsonlite::fromJSON("https://opendata.cwb.gov.tw/fileapi/v1/opendataapi/F-C0032-001?Authorization=rdec-key-123-45678-011121314&format=JSON") ->
    weather_next36hours
  SOAR::Store(weather_next36hours) # 存在.R_cache environment中
}

SOAR::Store(weather_next36hours)

  • 創造一個.R_Cache環境並把weather_next36hours移到那裡放。
askSilly_weather2 <- function(locationInput,dateInput){
  if(!exists("weather_next36hours")){
      jsonlite::fromJSON("https://opendata.cwb.gov.tw/fileapi/v1/opendataapi/F-C0032-001?Authorization=rdec-key-123-45678-011121314&format=JSON") ->
      weather_next36hours
    SOAR::Store(weather_next36hours) # 存在.R_cache environment中
  }  
  (weather_next36hours$cwbopendata$dataset$location$locationName == locationInput) -> pick_location
  
  weather_next36hours$cwbopendata$dataset$location$weatherElement[pick_location][[1]] -> weatherAtLocation
  (weatherAtLocation$elementName=="MaxT") ->
    pick_MaxT
  (weatherAtLocation$elementName=="MinT") ->
    pick_MinT
  weatherAtLocation$time[pick_MaxT][[1]]$parameter$parameterName[[1]] -> maxT
  weatherAtLocation$time[pick_MinT][[1]]$parameter$parameterName[[1]] -> minT
  
  glue::glue("{locationInput} {dateInput} 氣溫,最高{maxT}度,最低{minT}度。")
}
system.time(
  askSilly_weather("新北市",today())
)
system.time(
  askSilly_weather("臺北市",today())
)

askSilly_weather("新北市",today())
askSilly_weather("臺北市",today())
SOAR::Remove(weather_next36hours)
system.time(
  askSilly_weather2("新北市",today())
)
system.time(
  askSilly_weather2("臺北市",today())
)

askSilly_weather2("新北市",today())
askSilly_weather2("臺北市",today())

5.3.2 if else

if(condition){
  body for TRUE condition
} else {
  body for FALSE condition
}
圖示if…else流程

Mathematical function

\[ f(n) = \begin{cases} n/2 & \quad \text{if } n \text{ is even}\\ -(n+1)/2 & \quad \text{if } n \text{ is odd} \end{cases} \]

# n 為偶數
n <- 54
fvalue <- n/2

# n 為奇數
n <- 33
fvalue <- -(n+1)/2

Condition設計:n「是/否」為偶數?

(n %% 2)==1 # 表示「奇數」; 或...

as.logical(n %% 2) # 只有0會變F,其他數值都是T

if…else…組合:

n <- 54
if(as.logical(n %% 2)){
  fvalue <- -(n+1)/2
} else {
  fvalue <- n/2
}
myFun <- function(n){
  if(as.logical(n %% 2)){
    fvalue <- -(n+1)/2
  } else {
    fvalue <- n/2
  }
  return(fvalue)
}

myFun(54)
myFun(33)

交卷提早時間

jsonlite::fromJSON("https://www.dropbox.com/s/d14j5hp3i5ps657/examSubmissionTimes.json?dl=1") -> examSubmissionTime


head(examSubmissionTime$section)
head(examSubmissionTime$time)
## [1] "56" "78" "78" "78" "56" "78"
## [1] "2020-05-27 14:49:18" "2020-05-27 16:43:41" "2020-05-27 16:36:14"
## [4] "2020-05-27 16:36:11" "2020-05-27 14:57:03" "2020-05-27 15:47:22"
  • 56節:deadline 下午3點

  • 78節(即非56節):deadline 下午5點

給定第i位學生,我們怎麼計算他/她的交卷提早時間?


沒有分歧情境

只有一個交卷時間:

i<-1
student_i_section <- examSubmissionTime$section[[i]]
student_i_time <- examSubmissionTime$time[[i]]

deadline <- lubridate::ymd_hms("2020-05-27 15:00:00", tz="Asia/Taipei") # 

howEarly <- deadline - lubridate::ymd_hms(
  student_i_time, tz="Asia/Taipei") 
print(howEarly)

有分歧情境

有兩個交卷時間:

student_i_section <- examSubmissionTime$section[[i]]
student_i_time <- examSubmissionTime$time[[i]]

===流程分歧點開始===

deadline <- lubridate::ymd_hms("2020-05-27 15:00:00", tz="Asia/Taipei")
deadline <- lubridate::ymd_hms("2020-05-27 17:00:00", tz="Asia/Taipei")

===流程分歧點結束===

howEarly <- deadline - lubridate::ymd_hms(student_i_time, tz="Asia/Taipei")
print(howEarly)

使用if…else控制情境分歧

Condition設計:

student_i_section=="56"

if…else…組合:

i<-1
student_i_section <- examSubmissionTime$section[[i]]
student_i_time <- examSubmissionTime$time[[i]]

if(student_i_section=="56"){
  deadline <- lubridate::ymd_hms("2020-05-27 15:00:00", tz="Asia/Taipei")
} else {
  deadline <- lubridate::ymd_hms("2020-05-27 17:00:00", tz="Asia/Taipei")
}

howEarly <- deadline - lubridate::ymd_hms(student_i_time, tz="Asia/Taipei")
print(howEarly)

我們可以使用function+map算出每位同學提早時間:

compute_howEarly <- function(student_i_section, student_i_time){
  # student_i_section <- examSubmissionTime$section[[i]]
  # student_i_time <- examSubmissionTime$time[[i]]
  
  if(student_i_section=="56"){
    deadline <- lubridate::ymd_hms("2020-05-27 15:00:00", tz="Asia/Taipei")
  } else {
    deadline <- lubridate::ymd_hms("2020-05-27 17:00:00", tz="Asia/Taipei")
  }
  
  howEarly <- deadline - lubridate::ymd_hms(student_i_time, tz="Asia/Taipei")
  # print(howEarly)
  
  return(howEarly)
}
compute_howEarly(examSubmissionTime$section[[1]],examSubmissionTime$time[[1]])
compute_howEarly(examSubmissionTime$section[[2]],examSubmissionTime$time[[2]])
compute_howEarly(examSubmissionTime$section[[3]],examSubmissionTime$time[[3]])
studentSequence <- 1:length(examSubmissionTime$section)

map(studentSequence,
    ~compute_howEarly(
      examSubmissionTime$section[[.x]],
      examSubmissionTime$time[[.x]])
    ) -> list_howEarly

78節和56節交卷提早時間比較

library(magrittr)
list_howEarly %>%
  unlist() -> examSubmissionTime$howEarly

pick_56 <- examSubmissionTime$section=="56"
mean(examSubmissionTime$howEarly[pick_56])
median(examSubmissionTime$howEarly[pick_56])

pick_78 <- examSubmissionTime$section=="78"
mean(examSubmissionTime$howEarly[pick_78])
median(examSubmissionTime$howEarly[pick_78])
## [1] 4.926104
## [1] 3.883333
## [1] 9.105044
## [1] 6.166667

5.3.3 if…else if… else

有時流程需要的分歧不只兩種情境,這時可以使用:

if(condition A){
  body for A 
} else if(condition B){
  body for B
} else if(condition C){
  body for C
} else {
  body for none of the above
}
  • 依需要可以不斷增加else if(...){....}的部份在中間。

  • else ifelse前面一定要保有前一段情境的結束}


成績等級:

  • >=90: 優 # condition A

  • 80-89:良 # condition B

  • 70-79:尚可 # condition C

  • 70以下:待加強 # else

readline("請輸入你的成績(整數): ") -> grade # 單獨執行
if(grade >=90){
  print("優")
} else if(grade>=80 & grade<=89){
  print("良")
} else if(grade>=70 & grade<=79){
  print("尚可")
} else {
  print("待加強")
}

各情境一定要互斥,即不可以有兩個情境有可能同時為TRUE,如果發生多個情境吻合會以第一個結果的body來執行。

grade <- 80
if(grade >=90){
  print("優")
} else if(grade>=75 & grade<=89){
  print("良")
} else if(grade>=70 & grade<=85){
  print("尚可")
} else {
  print("待加強")
}
grade <- 80
if(grade >=90){
  print("優")
} else if(grade>=70 & grade<=85){
  print("尚可")
} else if(grade>=75 & grade<=89){
  print("良")
} else {
  print("待加強")
}

5.3.4 switch

另一種條件式執行常用在condition種類煩雜或要全部以「是/否」問句來切出所有互斥condition情境不容易設計時。

  • condition改成用文字描述,即conditionExpression。

  • 不同conditionExpression與對應body內容改成使用一對對的:

    • "conditionExpression文字"={body 內容} 的name=value pair
switch(實現的conditionExpression,
       "conditionExpression1"= {    },
       "conditionExpression2"= {    },
       :
       :
       "conditionExpressionN"= {    },
       {    })

Mathematical function

\[ f(n) = \begin{cases} n/2 & \quad \text{if } n \text{ is even}\\ -(n+1)/2 & \quad \text{if } n \text{ is odd} \end{cases} \]

n<- 540

conditionExpression_outcome=
  ifelse(n %% 2==0, "even", "odd") 

switch(
  conditionExpression_outcome,
  "even"={fvalue <- n/2}, # 偶數
  "odd"=fvalue <- -(n+1)/2, # 奇數;只有一行指令可省略{}
  warning("n要整數喔")  
)

print(fvalue)

ifelse(test, yes, no)是超級好用/常用的函數:

  • test: class logical. 測試條件的結果

  • yes: 結果為T 時你希望的回傳值

  • no: 結果為F 時你希望的回傳值

grades <- c(52, 77, 59, 88, 90)

ifelse(grades >= 60, "及格", "不及格")

在R裡{...}(大括號, brace):

  • 若只有一行指令則{}符號可省略。

  • 依照上一個特性,function(...){....}的body若只有一行指令可省略{...}改寫成function(...) ..., 只是要小心body … 要接在function(...)之後不可換行。

miniFun <- function(){
  lubridate::now()
}
miniFun()
miniFun2 <- function() lubridate::now()
miniFun2()
  • 若最後一個被執行的指令會產生print在螢幕的效果,則可以用{...}-><-{...}將這print的值存出來。
result <- 
  {
    x <- 2
    y <- 3
    x**y+15
  }
print(result)
result2 <-
  {
    x <- 2
    y <- 3
    if(x< 3){
      warning("x值太小")
    } else {
      x**y+15
    }
  }
print(result2)
  • 依照上一個特性,function(...){....}的body若最後一個「被執行」的指令是會印在螢幕的值,如該值要當回傳值可以不用return(...)就可以產生值回傳效果。
myFun <- function(x,y){
  return(x**y+15)
}

# 等同於
myFun2 <- function(x,y){
  x**y+15
}

myFun(5,3) -> outcome
myFun2(5,3) -> outcome2
print(outcome)
print(outcome2)

cut:連續轉類別

可適當使用cut()函數將與「連續型」數值變數有關的condition轉成需要的字串表示,

cut(x, c(a,b,c))

會將x分成(a,b], (b,c], 及NA 三大類。

  • x只要type是integer, double的資料都可使用,所以日期,時間都可以

  • (a,b]在數學上是a< . <=b,所以左側a值是「不包含」在裡面的

  • 其中最小值可以是負無窮-Inf, 最大值可以是正無窮Inf

a <- c(1,2,3)
cut(a, c(1,2,3))

數字成績轉英文字母成績 成績等級:

  • >=90: A 同時螢幕出現“好棒棒” (89<…<=100)

  • 80-89:B 同時螢幕出現“好棒” (79<…<=89)

  • 70-79:C 同時螢幕出現“棒” (69<…<=79)

  • 70以下:F 同時螢幕出現"-_-" (-1<…<=69)

grade <- sample(1:100, 10, replace=T)

grade %>%
  cut(c(-1,69,79,89,100)) -> grade

levels(grade)

switch(
  as.character(grade[[1]]),
  "(-1,69]"={
    print("-_-")
    "F"},
  "(69,79]"={
    print("棒")
    "C"
    },
  "(79,89]"={
    print("好棒")
    "B"
    },
  "(89,100]"={
    print("好棒棒")
    "A"
    }
) -> letterGrade # 有回存時要螢幕印出的訊息一定要加print

寫一個compute_letterGrade(myGrade)函數, 可以依myGrade不同而回傳letterGrade且出現要求文字。


管家機器人:

一家三口,

  • 早上(06:00-09:00): 媽媽讀《經濟學人》,爸爸讀《WSJ》,提醒小明“檢查書包東西都有帶嗎?”

  • 晚上(17:00-19:00): 媽媽準備全家晚餐點foodpanda,爸爸瀏覽tripadvisor(https://www.tripadvisor.com/)規劃週末全家旅行,提醒小明“作業寫好了嗎?”

  • 晚上(23:30-次日淩晨1點): 媽媽聆聽Spotify Jazz Classics(https://open.spotify.com/playlist/37i9dQZF1DXbITWG1ZJKYt)

  • 其他時段:“機器人要休息,饒了我吧~~”

nowtime <- glue::glue("{today()} 18:00:00") %>% ymd_hms(tz="Asia/Taipei")

library(lubridate)
library(glue)

# 建立可當cutpoints的一天時間點
cutpoints <-
  c(
    glue("{today()} 06:00:00"),
    glue("{today()} 09:00:00"),
    glue("{today()} 17:00:00"),
    glue("{today()} 19:00:00"),
    glue("{today()} 23:30:00"),
    glue("{today()+days(1)} 01:00:00")
  )
cutpoints %>%
  ymd_hms(tz="Asia/Taipei") -> cutpoints

## 將nowtime轉成它對應的時段是"morning", "evening", 或其他。
cut(nowtime, cutpoints) -> nowtime
levels(nowtime)[c(1,3,5)] <-
  c("morning","evening","jazz time")

## 使用switch決定要做什麼事
switch(
  as.character(nowtime),
  "morning"={
    print("要不要來閱讀點國際時事?")
    browseURL("https://economist.com")
  },
  "evening"={
    print("需不需要點餐呢?")
    browseURL("https://www.foodpanda.com.tw/")
  },
  "jazz time"={
    print("放鬆聽點Jazz。")
    browseURL("https://open.spotify.com/playlist/37i9dQZF1DXbITWG1ZJKYt")
  },
  {
    print("機器人要休息,饒了我吧~~")
  }
)
whatNeedToDo_butler_mom <- function(nowtime=now()){
  library(lubridate)
  library(glue)

  cutpoints <-
    c(
      glue("{today()} 06:00:00"),
      glue("{today()} 09:00:00"),
      glue("{today()} 17:00:00"),
      glue("{today()} 19:00:00"),
      glue("{today()} 23:30:00"),
      glue("{today()+days(1)} 01:00:00")
    )
  cutpoints %>%
    ymd_hms(tz="Asia/Taipei") -> cutpoints
  
  cut(nowtime, cutpoints) -> nowtime
  levels(nowtime)[c(1,3,5)] <-
    c("morning","evening","jazz time")
  
  switch(
    as.character(nowtime),
    "morning"={
      print("要不要來閱讀點國際時事?")
      browseURL("https://economist.com")
    },
    "evening"={
      print("需不需要點餐呢?")
      browseURL("https://www.foodpanda.com.tw/")
    },
    "jazz time"={
      print("放鬆聽點Jazz。")
      browseURL("https://open.spotify.com/playlist/37i9dQZF1DXbITWG1ZJKYt")
    },
    {
      print("機器人要休息,饒了我吧~~")
    }
  )
}

ymd_hms(glue::glue("{today()} 08:00:00"),tz="Asia/Taipei") %>%
  whatNeedToDo_butler_mom()

ymd_hms(glue::glue("{today()} 14:00:00"),tz="Asia/Taipei") %>%
  whatNeedToDo_butler_mom()

ymd_hms(glue::glue("{today()} 18:00:00"),tz="Asia/Taipei") %>%
  whatNeedToDo_butler_mom()

ymd_hms(glue::glue("{today()+days(1)} 00:20:00"),tz="Asia/Taipei") %>%
  whatNeedToDo_butler_mom()

上面的流程其實也可以用if… else if… else來做而不用switch,請用if… else if… else來創造whatNeedToDo_butler_mom。

請完成給爸爸和小明的管家機器人,whatNeedToDo_butler_dad和whatNeedToDo_butler_ming。


5.3.5 logical condition

由於if, if…else, if…if else…else, 都是用來決定要不要執行某個body,所以(condition) 必需要是「一個」T/F logical value。


比對答案

myAnswer <- c(2,3,6)
correctAnswer <- c(2,3,5)

if(myAnswer == correctAnswer){ # 只取用第一個T/F
  print("你答對了")
}

R3.5以上版本可以設定

Sys.setenv("_R_CHECK_LENGTH_1_CONDITION_" = "true")

禁止length>1的logical condition.

all, any

myAnswer <- c(2,3,6)
correctAnswer <- c(2,3,5)

if(all(myAnswer == correctAnswer)){ # 要全TRUE
  print("你答對了")
}
if(any(myAnswer == correctAnswer)){ # 只要有一個TRUE
  print("裡頭有數字是對的")
}

寫一個grading(myAnswer, correctAnswer)函數可以用來比對兩者是否class及所有元素都相同,是才回傳10分,不是回傳0分。

&& ||

有時「資訊到這裡就夠判斷情境」會產生,這時可以用&&或||


對答案:

  • class, 內容都要對
myAnswer <- c(1,2,3)
correctAnswer <- factor(c(1,2,3))

if(is.factor(myAnswer) && all(myAnswer==correctAnswer)){
  print("答對了")
  10
} else {
  print("答錯了")
  0
}-> myGrade
myGrade
if(is.factor(myAnswer) & all(myAnswer==correctAnswer)){
  print("答對了")
  10
} else {
  print("答錯了")
  0
}-> myGrade
myGrade
  • &會計算所有relations,&&只計算到第一個出現FALSE的relation.

    • &&用在「有一個錯就算錯」的情境。
  • |會計算所有relations,||只計算到第一個出現TRUE的relation.

    • ||用在「有一個對就算對」的情境。

在進行condition execution時,使用&&, ||會比&, |更有運算效率。

condition最好少使用&|因為兩邊relations若為logical向量長度>1,結果也會是個logical向量長度>1。


只要符合以下資格均可申請補助:

  • 年齡>=65

  • 家庭子孩數>3

myAge <- 40
myChildrenNumber <- 5

if(myAge >=65 | myChildrenNumber >3){
  "符合申請資格"
} else {
  warning("不符合申請資格")
}

if(myAge >=65 ||  myChildrenNumber >3){
  "符合申請資格"
} else {
  warning("不符合申請資格")
}

那改成

myAge <- 67
myChildrenNumber <- 5

5.3節主要在介紹「依情境執行不同body」的conditional execution,另外還有「依情境不同產生不同值」的conditional assignment。

一個logical relation:

x <- c(2,5,10,-21,3,8)
ifelse(x %% 2==0, "even", "odd")

多個logical relations:

y <- sample(40:100,20, replace=T)
dplyr::case_when(
  y < 60 ~ "F",
  60<=y & y < 70 ~"D",
  71<=y & y < 80 ~"C",
  80<=y & y < 90 ~"B",
  90<=y ~ "A"
)

將5.4.3小節中whatNeedToDo_butler_mom body裡的cut改成使用dplyr::case_when.

5.3.6 斷句

關於R的斷句:

只要指令不完整就繼續往下一行找。

在if-else if-else的使用下,只要

  • } else 有同時出現

其他部份的斷句時機可自由決定。

# if... else例子
flag=1

if(flag==1){
  print("flag 1.")
} else {
  print("else.")
}

stop("以下有誤")
if(flag==1){
  print("flag 1.")
} 
else {
  print("else.")
}
# if else if else例子
flag=1

if(flag==1){
  print("flag 1.")
} else if(flag==2){
  print("flag 2.")
} else {
  print("else.")
}

if(flag==1){
  print("flag 1.")
} else 
if(flag==2){
  print("flag 2.")
} else 
{
  print("else.")
}

stop("以下有誤")
if(flag==1){
  print("flag 1.")
} else 
if(flag==2){
  print("flag 2.")
} 
else {
  print("else.")
}

一般推薦的斷句模式:

if(){ # 條件情境描述
  
}
if(){ # 條件情境描述
  
} else { # 條件情境描述
  
}
if(){ # 條件情境描述
  
} else if(){ # 條件情境描述
  
} else { # 條件情境描述
  
}

5.3.7 綜合練習

1. 消費者選擇

效用函數: \[U(a1,a2)=a1^\alpha * a2^{(1-\alpha)}-m\] a1是該商品提供之服務所帶來的愉快程度,a2是該商品操作簡便性,\(\alpha\)是個介於0與1之間的數字,\(m\)則是購買此商品所要付出的金額。

想像有一系列類似的App你在考慮購買且只買一次、只買一個,每個App可用一組\((a1,a2,m)\)的數字組合來代表,n個App可表示成一個集合\({(a1_1,a2_1,m_1),(a1_2,a2_2,m_2),... ,(a1_n,a2_n,m_n)}\),消費者只選擇這些App中效用函數值最高的那個。

1.1 創造Ufun(a1, a2, m, alpha=0.5)函數,其中

Arguments:

a1, a2, m, alpha: 均為class numeric

Value:

回傳arugment values下所對應的效用函數值(class numeric)

1.2 以下10個App計算並回傳它們的效用值(class numeric, length=10)

Apps_10 <- list(
  c(0.38,0.74,0.19), c(0.39,0.46,0.26), c(0.56,0.3,0.32), c(0.54,0.31,0.40), c(0.90,0.56,0.43), c(0.39,0.13,0.23), 
  c(0.83,0.74,0.39), c(0.66,0.84,0.37), c(0.41,0.49,0.35),
  c(0.49,0.35,0.20))

1.3 最大效用下消費者會買那一個App?

1.4 若alpha=0.3,消費者要買那一個App?

1.5 若alpha=0.95,消費者要買那一個App?

2. 中文組距

原始資料收回後常會依某些數值區間來分成不同組別,且描述手法均類似:

  • “未滿200,000元”, “200,000~299,999元”, “300,000元及以上”

描述手法:「區間」會有上下限兩個數字,最低與最高的組均只有一個數字。

請寫一個str_cut(x, cutpoints)函數,它能萬用的將x轉成依中文組距描述的類別資料

Arguement:

  • x: class integer.

  • cutpoints: class character, 如c(“未滿200,000元”, “200,000~299,999元”, “300,000元及以上”)

Value: 回傳值為x依中文組距描述分類後的factor。

5.4 Iteration

Rule of thumb: never copy and paste more than twice.

  • 重覆兩次(包含第一個)okay. 三次…考慮一下迴圈吧!

但在設計迴圈時可以copy/paste 3 times來理解body如何設計


找出哪幾筆為“男”:

sampleData <- list(
  list("男", 45), list("女", 32), list("男",50), list("男",33), list("女", 21)
)
  • 男女只在sampleData每一個元素底下的第一個元素
# 前三筆性別
sampleData[[1]][[1]]
sampleData[[2]][[1]]
sampleData[[3]][[1]]

5.4.1 Iteration components

我們在使用map時寫copy/paste程序3次,目的在確認:

  • Sequence: 即[[1]], [[2]], [[3]]出現的位置。

  • Body: 要重覆做的SOP,即~.x[[1]]

而map最後會把每次Body的執行結果存在:

  • Output: 每次body執行完要存的形式,即map最後的list class output。

5.4.2 Two types of sequence

反覆要做的事

sampleData[[1]][[1]]  
sampleData[[2]][[1]] 
sampleData[[3]][[1]] 

使用pipe寫法可以清楚分離sequence及body(SOP)。兩種sequence表示:

# 串接寫法(I): external dispatch
sampleData[[1]] %>% {.[[1]]} 
sampleData[[2]] %>% {.[[1]]}
sampleData[[3]] %>% {.[[1]]}

map(sampleData, ~{.x[[1]]})

# 串接寫法(II): internal dispatch
1 %>% {sampleData[[.]][[1]]}  
2 %>% {sampleData[[.]][[1]]}  
3 %>% {sampleData[[.]][[1]]}

map(1:5, ~{sampleData[[.x]][[1]]})
# map在單維度遞迴時,.x也可以只寫.
map(1:5, ~{sampleData[[.]][[1]]})
External dispatch sequence
Internal dispatch sequence
eggs <- rep("雞蛋x1", 8)

fryEgg <- function(egg){
  str_replace(egg, "雞蛋", "荷包蛋")
}

# external dispatch
eggs[[1]] %>% fryEgg(.)
eggs[[2]] %>% fryEgg(.)
eggs[[3]] %>% fryEgg(.)

map(eggs, ~fryEgg(.x)) -> friedEggs1

# internal dispatch
1 %>% {fryEgg(eggs[[.]])}
2 %>% {fryEgg(eggs[[.]])}
3 %>% {fryEgg(eggs[[.]])}

map(1:8, ~{fryEgg(eggs[[.]])}) -> friedEggs2

vectorized function

grade <- c(45, 74, NA)

i<-3

grade_i <- grade[[i]]
if(!is.na(grade_i)){
  if(grade_i >= 60){
    "P"
  } else if(grade_i < 60 ) {
    "F"
  }
} else {
  "缺考"
}
pass_or_fail <- function(grade_i){
  if(!is.na(grade_i)){
    if(grade_i >= 60){
      "P"
    } else if(grade_i < 60 ) {
      "F"
    }
  } else {
    "缺考"
  }
}

pass_or_fail(grade[[1]])
pass_or_fail(grade[[2]])
pass_or_fail(grade[[3]])

# 可否直接input整個grade vector
warning("不是vectorised function")
pass_or_fail(grade)

函數使用時若出現output value assigned動作時(即pass_fail_i <-),相當於執行了函數body pass_fail_i <-{...},依switch小節的{...}處理原則:

  • 若最後一個被執行的指令會產生print在螢幕的效果,則可以用{…}->或<-{…}將這print的值存出來。

此時可以省略return()

可:

  • use map to wrap around non-vectorized function

產生vectorized function

grade[[1]] %>% {pass_or_fail(.)}
grade[[2]] %>% {pass_or_fail(.)}
grade[[3]] %>% {pass_or_fail(.)}

map(grade, ~{pass_or_fail(.)}) # map to list

map_chr(grade, ~{pass_or_fail(.)}) # map to atom. vectof of class character

map_pass_fail <- function(grade){
  map_chr(grade, ~{pass_or_fail(.)})
}
map_pass_fail(grade)

若你確信你map的list輸出每個元素只有一個值,且大家都相同class,則你可以依class的類形使用:

  • map_chr

  • map_lgl

  • map_dbl, map_int

省了unlist那一步。

請問map_pass_fail的定義是否受global environment裡的grade元素「值」影響?即執行rm(grade)刪除grade物件,以下程序執行上會不會有問題?

map_pass_fail(c(77,43,68,NA))

常被拿來針對物件元素進行一一計算的函數建議可以將它改成vectorized function,以後在維護時比較容易。

Internal dispatching的優勢

當Body要同時對多個物件同時進行「元素一一處理」時,internal dispatch便顯得便利:

eggs <- rep("雞蛋x1",10)
ham <- rep("火腿x1", 10)
toast <- rep("土司2片",10)

toast_withEggHam <- function(toast=NULL, egg=NULL, ham=NULL){
  if(is.null(toast) || !str_detect(toast, "土司")){stop("少了土司")}
  if(is.null(egg) || !str_detect(egg, "蛋")){stop("少了蛋")}
  if(is.null(ham) || !str_detect(ham, "火腿")){stop("少了火腿")}
  "火腿蛋三明治"
}

# 土司、火腿、蛋 第一份出列
1 %>% {toast_withEggHam(toast=toast[[.]], egg=eggs[[.]], ham=ham[[.]])}
# 土司、火腿、蛋 第二份出列
2 %>% {toast_withEggHam(toast=toast[[.]], egg=eggs[[.]], ham=ham[[.]])}
# 土司、火腿、蛋 第三份出列
3 %>% {toast_withEggHam(toast=toast[[.]], egg=eggs[[.]], ham=ham[[.]])}


map(1:10,
    ~toast_withEggHam(toast=toast[[.x]], egg=eggs[[.x]], ham=ham[[.x]]))

各系課程規劃

執行以下程序可以得到臺北大學100-107學年的開課資料courseStructure:

jsonlite::fromJSON("https://www.dropbox.com/s/7myzzdnoor21hye/courseStructure2.json?dl=1") -> courseStructure

一位剛入學的經濟系新生想大致了解他系上對他未來四年的課程規劃是什麼?於是他想先看一下過去狀況。

以100學年入學之經濟系學生為對象,找出這群學生大一到大四的系上課程規劃是什麼?

entranceYear <- 100
major <- "經濟系"
allGrades <- paste0(major, 1:4)
academicYears <- entranceYear+0:3

# 100學年 1年級
acadYear_i <- academicYears[[1]]
grade_i <- allGrades[[1]]
pick <-
  (courseStructure$學年==acadYear_i 
    &
    str_detect(courseStructure$應修系級, grade_i))
unique(courseStructure$科目名稱[pick])

# 101學年 2年級
acadYear_i <- academicYears[[2]]
grade_i <- allGrades[[2]]
pick <-
  (courseStructure$學年==acadYear_i 
    &
    str_detect(courseStructure$應修系級, grade_i))
unique(courseStructure$科目名稱[pick])

# 102學年 3年級
acadYear_i <- academicYears[[3]]
grade_i <- allGrades[[3]]
pick <-
  (courseStructure$學年==acadYear_i 
    &
    str_detect(courseStructure$應修系級, grade_i))
unique(courseStructure$科目名稱[pick])

# 103學年 4年級
acadYear_i <- academicYears[[4]]
grade_i <- allGrades[[4]]
pick <-
  (courseStructure$學年==acadYear_i 
    &
    str_detect(courseStructure$應修系級, grade_i))
unique(courseStructure$科目名稱[pick])


  1. 100學年1年級-103學年4年級,有哪幾行是一模一樣的?
pick <-
  (courseStructure$學年==acadYear_i 
    &
    str_detect(courseStructure$應修系級, grade_i))
unique(courseStructure$科目名稱[pick])
  1. 以上的SOP要能運作,哪些物件要存在執行環境?
  • courseStructure, acadYear_i, grade_i


將(A)(B)形成函數

get_courses <- function(acadYear_i, grade_i, courseStructure){
  pick <-
  (courseStructure$學年==acadYear_i 
    &
    str_detect(courseStructure$應修系級, grade_i))
  
  return(
    unique(courseStructure$科目名稱[pick])
  )
}

重寫100學年1年級-103學年4年級

# 100學年 1年級
acadYear_i <- academicYears[[1]]
grade_i <- allGrades[[1]]
get_courses(acadYear_i, grade_i, courseStructure)

# 101學年 2年級
acadYear_i <- academicYears[[2]]
grade_i <- allGrades[[2]]
get_courses(acadYear_i, grade_i, courseStructure)

# 102學年 3年級
acadYear_i <- academicYears[[3]]
grade_i <- allGrades[[3]]
get_courses(acadYear_i, grade_i, courseStructure)

# 103學年 4年級
acadYear_i <- academicYears[[4]]
grade_i <- allGrades[[4]]
get_courses(acadYear_i, grade_i, courseStructure)


濃縮

# 100學年 1年級
get_courses(academicYears[[1]], allGrades[[1]], courseStructure)

# 101學年 2年級
get_courses(academicYears[[2]], allGrades[[2]], courseStructure)

# 102學年 3年級
get_courses(academicYears[[3]], allGrades[[3]], courseStructure)

# 103學年 4年級
get_courses(academicYears[[4]], allGrades[[4]], courseStructure)

使用pipe

1 %>% 
  {get_courses(academicYears[[.]], allGrades[[.]], courseStructure)}
2 %>% 
  {get_courses(academicYears[[.]], allGrades[[.]], courseStructure)}
3 %>% 
  {get_courses(academicYears[[.]], allGrades[[.]], courseStructure)}
4 %>% 
  {get_courses(academicYears[[.]], allGrades[[.]], courseStructure)}

使用map

1:4 %>%
  map(~{get_courses(academicYears[[.]], allGrades[[.]], courseStructure)})




Iteration in functional: map

1:4 %>%
  map(~{
    get_courses(academicYears[[.]], 
                allGrades[[.]], 
                courseStructure)})
  • Sequence: 1:4

  • Body: {get_courses(academicYears[[.]], allGrades[[.]], courseStructure)}, 以formula(另一種function形式)包裝。

  • Output: list class, length=Sequence length

5.4.3 for loop

output <- vector("{type}", length={len})
for(.x in {sequence}){
  {body}
}

這裡"{…}" 均是需要視情況定義的部份。

vector(mode, length):

  • mode: character class,代表container所要用來裝的值之type。

  • length: integer class,代表container要有幾個空位。


map範例:

map iteration:(請先跑)
### 前置作業
entranceYear <- 100
major <- "經濟系"
allGrades <- paste0(major, 1:4)
academicYears <- entranceYear+0:3

jsonlite::fromJSON("https://www.dropbox.com/s/7myzzdnoor21hye/courseStructure2.json?dl=1") -> courseStructure

get_courses <- function(acadYear_i, grade_i, courseStructure){
  pick <-
  (courseStructure$學年==acadYear_i 
    &
    str_detect(courseStructure$應修系級, grade_i))
  
  return(
    unique(courseStructure$科目名稱[pick])
  )
}
# 前置作業,接map iteration
map(1:4, 
    ~{
      get_courses(academicYears[[.x]], 
              allGrades[[.x]], 
              courseStructure)})

for iteration:(請先跑前置作業)

# 前置作業,接for iteration
output <- vector("list", length=4)
for(.x in 1:4){
  get_courses(academicYears[[.x]], 
                allGrades[[.x]], 
                courseStructure) -> output[[.x]]
}

若internal dispatching sequence的長度是對應到某個物件元素個數,如上面1:4是對應academicYears(亦對應allGrades),則1:4可用seq_along(academiYears)取代。


eggs <- rep("雞蛋x1",10)
ham <- rep("火腿x1", 10)
toast <- rep("土司2片",10)

toast_withEggHam <- function(toast=NULL, egg=NULL, ham=NULL){
  if(is.null(toast) || !str_detect(toast, "土司")){stop("少了土司")}
  if(is.null(egg) || !str_detect(egg, "蛋")){stop("少了蛋")}
  if(is.null(ham) || !str_detect(ham, "火腿")){stop("少了火腿")}
  "火腿蛋三明治"
}

map approach:

map(1:10,
    ~toast_withEggHam(toast=toast[[.x]], egg=eggs[[.x]], ham=ham[[.x]]))

for approach:

output <- vector("character", 10)
for(.x in 1:10){
  toast_withEggHam(toast=toast[[.x]], egg=eggs[[.x]], ham=ham[[.x]]) -> output[[.x]]
}

累計型output

Summation

\[\sum_{i=1}^N a_i\]

a <- sample(1:100, 10, replace=T)
print(a)
  • Sequence: 1:10

  • body: 到目前sequence .x前已經加總的值+ a[[.x]]

  • output: .x到10最後算完的值。

sum <- 0
for(.x in 1:10){
  sum <- sum+a[[.x]]
}

print(sum)

長度不定型output

每次抽一個介於0到100的數字(抽出放回)抽10次,但每次必需是3的倍數才留下來。

output <- c()
for(.x in 1:10){
  new <- sample(0:100,1)
  if(new %% 3==0){
    output <- c(output, new)
  }
}

print(output)

5.4.4 while loop

有時我們面臨sequence長度未知,如擲一銅板直到出現5次正面才停。

sum <- 0
for(i in 1:10){
  newToss <- sample(c("正","反"), 1, replace=T)
  if(newToss == "正"){
    sum <- sum+1
  }
  print(glue::glue("已擲{i}次得到{sum}次正面"))
}

for loop用很長的sequence再加上條件式break:

sum <- 0
for(i in 1:100){
  newToss <- sample(c("正","反"), 1, replace=T)
  if(newToss == "正"){
    sum <- sum+1
  }
  print(glue::glue("已擲{i}次得到{sum}次正面"))
  if(sum==5){
    break
  }
}

break會完全終止迴圈,而之前學到的next是不執行其以下的body直接跳下一個sequence值。

while會一直反覆執行body直到conditionCondition為FALSE:

while(continueCondition){
  body
}
sum <- 0
count <- 0 # 計數器
while(sum<5){
  count <- count+1 # 計數器+1
  newToss <- sample(c("正","反"), 1, replace=T)
  if(newToss == "正"){
    sum <- sum+1
  }
  print(glue::glue("已擲{count}次得到{sum}次正面"))
}

由於while並沒有迴圈執行次數上限,若沒設好結束條件程式會一直跑下去鎖死電腦。為避免此問題,一般我們會放計數器,並在條件裡放計數上限,如下方四個#註明位置:

count <- 0 # 計數器開始值
max_count <- 500 # 計數上限
while(continueCondition && count <= max_count){ # 增加計數上限條件
  count <- count+1 # 計數器加1
  body
}

之前的(有限)迴圈也可以用while寫:

set.seed(1000) # 控制sample抽出的數字sequence固定,通常進行方法比對用

output <- c()
for(.x in 1:10){
  new <- sample(0:100,1)
  if(new %% 3==0){
    output <- c(output, new)
  }
}

print(output)
set.seed(1000) # 控制sample抽出的數字sequence固定,通常進行方法比對用

count <- 0 # 計數器起始值
output <- c()
while(count <= 10){ # 計數上限條件
  count <- count+1 # 計數器+1
  new <- sample(0:100,1)
  if(new %% 3==0){
    output <- c(output, new)
  }
}

print(output)
a <- sample(1:100, 10, replace=T)
print(a)

sum <- 0
for(.x in 1:10){ 
  sum <- sum+a[[.x]]
}

print(sum)
count <- 0 # 計數器起始值
sum <- 0
while(count <= 10){ # 計數上限條件
  count <- count+1 # 計數器+1
  sum <- sum+a[[count]]
}

print(sum)

幾乎每一個iteration都可以用functional, for, while寫一次,but …

“…the real downside of for loops is that they’re very flexible: a loop conveys that you’re iterating, but not what should be done with the results. Just as it’s better to use while than repeat, and it’s better to use for than while (Section 5.3.2), it’s better to use a functional than for. Each functional is tailored for a specific task, so when you recognise the functional you immediately know why it’s being used.” – from Advanced R.

  • 不過若沒有追求時間效率的需求,還是以符合直覺的寫法優先,日後維護也比較能進入狀況。

5.4.5 綜合練習

  1. Mathematical function

\[ f(n) = \begin{cases} n/2 & \quad \text{if } n \text{ is even}\\ -(n+1)/2 & \quad \text{if } n \text{ is odd} \end{cases} \]

針對以上的函數我們架構了,但它並不是vectorized function,請將它升級成vectorized function, myFun2, 使得以下指令可正常運作:
myFun <- function(n) {
    if (as.logical(n%%2)) {
        fvalue <- -(n + 1)/2
    } else {
        fvalue <- n/2
    }
    return(fvalue)
}
myFun2(c(-11,32,19,20))
  1. askSilly_weather 3.0
並不是個vectorized function, 一次要查詢多個城市時(如下)它只會回傳第一個城市的氣溫:
askSilly_weather2 <- function(locationInput,dateInput){
  if(!exists("weather_next36hours")){
      jsonlite::fromJSON("https://opendata.cwb.gov.tw/fileapi/v1/opendataapi/F-C0032-001?Authorization=rdec-key-123-45678-011121314&format=JSON") ->
      weather_next36hours
    SOAR::Store(weather_next36hours) # 存在.R_cache environment中
  }  
  (weather_next36hours$cwbopendata$dataset$location$locationName == locationInput) -> pick_location
  
  weather_next36hours$cwbopendata$dataset$location$weatherElement[pick_location][[1]] -> weatherAtLocation
  (weatherAtLocation$elementName=="MaxT") ->
    pick_MaxT
  (weatherAtLocation$elementName=="MinT") ->
    pick_MinT
  weatherAtLocation$time[pick_MaxT][[1]]$parameter$parameterName[[1]] -> maxT
  weatherAtLocation$time[pick_MinT][[1]]$parameter$parameterName[[1]] -> minT
  
  glue::glue("{locationInput} {dateInput} 氣溫,最高{maxT}度,最低{minT}度。")
}
askSilly_weather2(c("臺北市","新北市","臺中市"),lubridate::now())

請創造askSilly_weather3,它是vectorized function。

  1. 以下程式隨機自0-100抽出30個數字:
a <- sample(0:100,30, replace=T)
print(a)

3.1 請計算其平均值a_mean.

3.2 令\(\mu\)代表上一題的平均值,請計算其樣本標準差(sample_sd),公式如下:

\[\sqrt{\sum_{i=1}^{30}(a_i-\mu)^2/(30-1)}\] (註:開根號除了使用**0.5, ^0.5外,也可以用sqrt()函數。)

  1. 現值 明年的100元若可以在今年用90元存到,那表示利率為(100-90)/90=0.1111。反過來說,明年的100元用100/(1+0.1111)可以反推等值現在的90元價值。這1/(1+0.1111)即稱之為折現率。若利率R維持每年不變,則現金流\(a_0, a_1, a_2, ..., a_N\)的現值為:

\[a_0+\frac{a_1}{1+R}+\frac{a_2}{(1+R)^2}+...+\frac{a_N}{(1+R)^N}\] 其中下標0表示今天,1表示明年,2表示後年,依此類推。

執行以下程式得到20年的現金流(介於1萬到5萬),a['0']代表\(a_0\), a['1']代表\(a_1\)依此類推。

a <- sample(10000:50000,20,replace=T)
names(a) <- 0:19

請寫一個函數DV(a,R):

arguments:

  • a: 現金流class numeric

  • R: 年利率

value: 回傳現金流的現值。

5.5 R Script

將所有的R chunks單獨抽出存成.R檔(原始chunk順序要保留):

knitr::purl("Rmd檔路徑")
  • 不要輸出的chunk可以用purl=FALSE設定,如```{r, purl=FALSE}

要使用時

source("R檔路徑")

5.6 Debug

  • 使用browser()函數於「暫停點」進入「browser debug環境」。
if(!exists("courseStructure")){
  jsonlite::fromJSON("https://www.dropbox.com/s/7myzzdnoor21hye/courseStructure2.json?dl=1") -> courseStructure
  SOAR::Store(courseStructure)
} else if (exists("courseStructure", envir = globalenv())){
  SOAR::Store(courseStructure)
}


get_courses <- function(acadYear_i, grade_i, courseStructure){
  pick <-
  (courseStructure$學年==acadYear_i 
    &
    str_detect(courseStructure$應修系級, grade_i))
  browser() # 暫停點(1)
  return(
    unique(courseStructure$科目名稱[pick])
  )
}

entranceYear <- 100
major <- "經濟系"
allGrades <- paste0(major, 1:4)
academicYears <- entranceYear+0:3

courseList <- vector("list", 4);
for(.x in 1:4){
  get_courses(academicYears[[.x]], allGrades[[.x]], courseStructure) -> courseList[[.x]]
  if(.x == 3) browser() # 暫停點(2)
}

在browser()環境時:

  • n:執行下一句,但不跳離browser debug環境

  • f:執行剩餘loop或function步驟,但不跳離browser debug環境

  • c:完全跳離browser debug環境並執行暫停點的下一句

  • Q:完全跳離browser debug環境並執行暫停點剩下script

for (i in 1:10) {
  print(i)
  if (i == 5) browser()
}