416homework

library(dplyr)

## 
## Attaching package: 'dplyr'

## The following objects are masked from 'package:stats':
## 
##     filter, lag

## The following objects are masked from 'package:base':
## 
##     intersect, setdiff, setequal, union

2

cal_median_new <- function(x){
  newx <- x %>% sort()
  n <- length(x)
  if(n/2==0)
    (newx[n/2]+newx[n/2+1])/2
  else
    newx[(n+1)/2]
}

cal_median_new(women$height)

## [1] 65

3

riffle <- function(x, y) {
  dl <- length(x) - length(y)
  y[(length(y)+1):(length(y)+dl)] <- rep(NA, dl)
  c(na.omit(as.numeric(t(cbind(x,y)))))
}

#test it
riffle(1:10, 50:55)

##  [1]  1 50  2 51  3 52  4 53  5 54  6 55  7  8  9 10

4

combo <- function(x){
  ll<-as.list(x)
  for(i in 2:length(x)){
    ll_new<-list(combn(x,i))
    ll<-c(ll,ll_new)
  }
  return(ll)
}
#text
x<-c("V1", "V2", "V3","V4")
combo(x)

## [[1]]
## [1] "V1"
## 
## [[2]]
## [1] "V2"
## 
## [[3]]
## [1] "V3"
## 
## [[4]]
## [1] "V4"
## 
## [[5]]
##      [,1] [,2] [,3] [,4] [,5] [,6]
## [1,] "V1" "V1" "V1" "V2" "V2" "V3"
## [2,] "V2" "V3" "V4" "V3" "V4" "V4"
## 
## [[6]]
##      [,1] [,2] [,3] [,4]
## [1,] "V1" "V1" "V1" "V2"
## [2,] "V2" "V2" "V3" "V3"
## [3,] "V3" "V4" "V4" "V4"
## 
## [[7]]
##      [,1]
## [1,] "V1"
## [2,] "V2"
## [3,] "V3"
## [4,] "V4"

5

c <- matrix(,nrow=6,ncol=6)

for(j in 1:6){
  for(i in 1:6){
    if(j==1){
      c[i,j]=i
    }
    else{
      c[i,j]=(c[i,j-1]-1)
      if(c[i,j]<1) c[i,j]=c[i,j]+7
    }
  }
}
head(c)

##      [,1] [,2] [,3] [,4] [,5] [,6]
## [1,]    1    7    6    5    4    3
## [2,]    2    1    7    6    5    4
## [3,]    3    2    1    7    6    5
## [4,]    4    3    2    1    7    6
## [5,]    5    4    3    2    1    7
## [6,]    6    5    4    3    2    1

plot.new()
plot.window(xlim = c(0, 6), ylim = c(0, 6), asp = 1)
my_cl <- c("indianred", "orange", "yellow", "forestgreen", "dodgerblue", "violet", "purple")
for(i in 1:6) {
  for(j in 1:6) {
    cc<-c[i,j]
    rect(i-1,j-1 ,i, j, col = my_cl[cc])
  }
}

6

set.seed(6666)
#投硬幣一百次
coin <- sample(c("H", "T"), 100, replace = TRUE)
coin.rle<-rle(coin)
#max length of coin (H and T)
tapply(coin.rle$lengths, coin.rle$values, max)

## H T 
## 6 8

#the probability of head or tail
sort(coin.rle$lengths, decreasing = TRUE) %>% table() %>% plot

7

#整理資料
dta <- read.table("C:/Users/user/Documents/plasma.txt",
                  sep="\t", header=F)
dta1 <- dta %>% as.matrix %>% gsub(" ",",",.) %>% 
          gsub(",*,",",",.) 
dta2 <- dta1 %>% strsplit(.,split=",",fix=T) %>% lapply(.,as.numeric) %>% lapply(.,na.omit)%>% unlist() %>% as.matrix() 
#矩陣
head(dta2)

##      [,1]
## [1,]   22
## [2,]    0
## [3,]  103
## [4,]   67
## [5,]   75
## [6,]   65

n<-length(dta2)

#空矩陣
m<-matrix(,nrow=84,ncol=9)

for(i in 1:n) {
  if(i<8) { 
    j<-(i-1)%/%7+1
    m[i,j]=dta2[i] 
  }
  
  else {
  a<-(i-1)%/%7+1
  if(a%%9==0){
    j=9
  }
  else{
    j=a%%9
  }
  h<-(i-1)%/%7
  k<-(i-1)%/%63
  ii<-i-7*(h-k)
  m[ii,j]=dta2[i]
  }
}

#讀進要求的資料等等用來檢查
dta_check <- read.table("C:/Users/user/Documents/plasma.csv",
                  sep=",", header=T)  
#patient
patient_tmp<-c()
patient<-c()
for(i in 101:112) patient_tmp <- c(patient_tmp,paste0("S",i)) 
for(i in 1:84) {
  j<-(i-1)%/%7+1
  patient[i] <-patient_tmp[j] 
}

#week
week<-rep(c(1,2,6,10,14,15,16),12)

#合併成data.frame
df<-data.frame(patient=patient,week=week,m) 
colnames(df)<-c("patient","week","plasma_ascorbic_acid",
         "leucocyte_ascorbic_acid","whole_blood_ascorbic_acid",
         "thiamin_status","grip_strength","red_cell_transketolase",
         "reaction_time","folate_serum","folate_red_cell")

#處理遺漏值
df[,-1] <- as.numeric(gsub(-9, NA, as.matrix(df[,-1])))

#確認
all.equal(df,dta_check)

## [1] TRUE