# tjsf.r: 単純集計用の関数群 (encoding utf-8) 2013/08/09 # 列名または列番号が存在するか確認し、番号または名前で返す # cname:列名群、xx:列の指定、xtype:数値か文字か(n,c) get.col <- function(cname, xx, xtype="n") { wxx <- if (is.character(xx)) seq_along(cname)[cname %in% xx] else if (is.numeric(xx) && xx <= length(cname)) cname[xx] else integer(0) if (length(wxx) == 0 || length(xx) != length(wxx)) return(integer(0)) if (xtype == "n") # 数値として返す res <- if (is.character(xx)) wxx else xx else if (xtype == "c") # 文字として返す res <- if (is.character(xx)) xx else wxx else res <- integer(0) return(res) } # 1次元・2次元データの項目名(列名・行名)の名称変更 # xx:table|matrixからなるリスト、elm1:旧項目名、elm2:新項目名、 # dw:縦・横・両方の指定(r,c,NULL) rename.item <- function(xx, elm1, elm2, dw=NULL) { if (is.null(xx)) return(xx) tbl_flag <- FALSE if (!is.list(xx)) { xx <- list(xx) tbl_flag <- TRUE } for (k in 1:length(xx)) { tt <- xx[[k]] if (!is.table(tt) && !is.matrix(tt)) next dd <- dimnames(tt) ldd <- length(dd) if (!is.list(dd) || (ldd != 1 && ldd != 2)) next if (ldd == 2) { if (is.null(dw) || length(which(dw == "c")) > 0) { ww <- colnames(tt) if (!is.null(ww)) { for (i in 1:length(elm1)) if (is.na(elm1[i])) ww[is.na(ww)] <- elm2[i] else ww[!is.na(ww) & ww==elm1[i]] <- elm2[i] colnames(tt) <- ww } } if (is.null(dw) || length(which(dw == "r")) > 0) { ww <- rownames(tt) if (!is.null(ww)) { for (i in 1:length(elm1)) if (is.na(elm1[i])) ww[is.na(ww)] <- elm2[i] else ww[!is.na(ww) & ww==elm1[i]] <- elm2[i] rownames(tt) <- ww } } } else { ww <- names(tt) if (!is.null(ww)) { for (i in 1:length(elm1)) if (is.na(elm1[i])) ww[is.na(ww)] <- elm2[i] else ww[!is.na(ww) & ww==elm1[i]] <- elm2[i] names(tt) <- ww } } xx[[k]] <- tt } if (tbl_flag) xx <- xx[[1]] return(xx) } # tableなどの次元名を変更 # xx:tableなどからなるリスト、dname1:縦の次元名、dname2:横の次元名 rename.dnn <- function(xx, dname1, dname2=NULL) { if (is.null(xx)) return(xx) tbl_flag <- FALSE if (!is.list(xx)) { xx <- list(xx) tbl_flag <- TRUE } dname <- if (is.null(dname2)) dname1 else c(dname1, dname2) if (length(dimnames(xx[[1]])) != length(dname)) warning("次元名の個数が合致しません") else for (i in 1:length(xx)) { if (!is.table(xx[[i]]) && !is.matrix(xx[[i]])) next names(dimnames(xx[[i]])) <- dname } if (tbl_flag) xx <- xx[[1]] return(xx) } # tableなどの次元名を取得 # xx:tableなどからなるリスト、またはtableなど get.dnn <- function(xx) { if (is.list(xx)) { for (tt in xx) if (is.table(tt) || is.matrix(tt)) { tbl <- tt break } } else tbl <- xx dd <- dimnames(tbl) if (is.list(dd)) return(names(dd)) else return(NULL) } # リスト中の各テーブルなどのまるめ処理 # xx:table|matrix|vectorからなるリスト、digits:有効な小数点以下の桁数 lround <- function(xx, digits=0) { if (is.null(xx)) return(xx) tbl_flag <- FALSE if (!is.list(xx)) { xx <- list(xx) tbl_flag <- TRUE } for (i in 1:length(xx)) { w <- typeof(xx[[i]]) if (w == "double" || w == "complex") xx[[i]] <- round(xx[[i]], digits) } if (tbl_flag) xx <- xx[[1]] return(xx) } # 縦軸・横軸の各々に着目した2種類のパーセントの算出 # tbl:table|matrix get.pct <- function(tbl) { dd <- dimnames(tbl) if (is.list(dd) && length(dd) == 2) { xx <- prop.table(addmargins(tbl,1), 1)*100 pct1 <- addmargins(xx, 2) xx <- prop.table(addmargins(tbl,2), 2)*100 pct2 <- addmargins(xx, 1) } else if (is.list(dd) && length(dd) == 1) { xx <- prop.table(tbl)*100 pct1 <- addmargins(xx, 1) pct2 <- NULL } else { pct1 <- NULL pct2 <- NULL } return(list(pct1=pct1, pct2=pct2)) } # 2つのテーブルまたはマトリクスの結合 # tbl1,tbl2:table|matrix、fmt:結合後のセルの書式(sprintf用) join.tbl <- function(tbl1, tbl2, fmt="%s(%s)") { if (!((is.table(tbl1) || is.matrix(tbl1)) && (is.table(tbl2) || is.matrix(tbl2)))) { warning("引数にはテーブルかマトリクスを指定して下さい") return(NULL) } nr <- nrow(tbl1) nc <- ncol(tbl1) nr2 <- if (!is.na(nrow(tbl2))) nrow(tbl2) else 0 nc2 <- if (!is.na(ncol(tbl2))) ncol(tbl2) else 0 if (!is.na(nc)) { # 2次元のtable|matrix res <- sapply(1:nr, function(i) sapply(1:nc, function(j) if (i>nr2 || j>nc2) tbl1[i,j] else sprintf(fmt, tbl1[i,j], tbl2[i,j]))) res <- t(res) rownames(res) <- rownames(tbl1) colnames(res) <- colnames(tbl1) if (is.table(tbl1)) res <- as.table(res) } else { # 1次元のtable res <- NULL for (i in 1:nr) res <- if (i>nr2) c(res, tbl1[i]) else c(res, sprintf(fmt, tbl1[i], tbl2[i])) res <- as.table(as.array(res)) rownames(res) <- rownames(tbl1) } dnn <- get.dnn(tbl1) if (!is.null(dnn)) names(dimnames(res)) <- dnn return(res) } # クラメール係数をカイ2乗検定の結果(xx)に付加して返す # xx:chisq.test()の結果 append.cramer <- function(xx) { mt <- xx$observed xx$cramer <- sqrt(xx$statistic / (min(nrow(mt), ncol(mt)) - 1) / sum(mt)) return(xx) } # データフレームの列をメモファイルに基づいてfactorとして再定義 # dtf:データフレーム、fname:メモファイル名、enc:メモファイルの文字コード remake.factor <- function(dtf, fname, enc=getOption("encoding")) { cn <- colnames(dtf) if (file.access(fname) != 0) { warning(sprintf("ファイル '%s' にアクセスできません",fname)) return(dtf) } infile <- file(fname, open="r", encoding=enc) lines <- readLines(infile) close(infile) for (line in lines) { xx <- unlist(strsplit(line, " *[|\t] *")) if (length(seq_along(cn)[cn %in% xx[1]]) == 0) { warning(sprintf("データフレーム中に '%s' という列はありません",xx[1])) next } if (length(xx) != 3) { warning("factorのlevels, labelsを取得できません") next } zz <- list(cname=xx[1], lvl=NULL, lbl=NULL) for (i in 2:3) zz[[i]] <- unlist(strsplit(xx[i], ",")) if (is.null(zz$lvl) || is.null(zz$lbl) || length(zz$lvl) != length(zz$lbl)) { warning("factorのlevelsとlabelsを照合できません") next } if (length(zz$lvl[zz$lvl == "NA"]) == 0) dtf[,zz$cname] <- factor(dtf[,zz$cname], levels=zz$lvl, labels=zz$lbl) else { zz$lvl[zz$lvl == "NA"] <- NA dtf[,zz$cname] <- factor(dtf[,zz$cname], levels=zz$lvl, labels=zz$lbl, exclude=NULL) } } return(dtf) } # 単一回答の集計 # dtf:データフレーム、col1:着目列1、col2:着目列2、opt:NAなどの扱い sa1 <- function(dtf, col1, col2=NULL, opt=c(NA,NaN)) { cn <- colnames(dtf) col1 <- get.col(cn, col1) if (!is.null(col2)) col2 <- get.col(cn, col2) if (length(col1) != 1 || (!is.null(col2) && length(col2) != 1)) { warning("列名または列番号の指定が不適当です") return(NULL) } if (!is.null(col2)) { # 2つの列が指定されているのでクロス表 tbl1 <- table(dtf[,col1], dtf[,col2], exclude=opt, dnn=c(cn[col1], cn[col2])) tbl2 <- addmargins(tbl1) xx <- get.pct(tbl1) pct1 <- xx$pct1 pct2 <- xx$pct2 } else { # 列が1つしか指定されていない tbl1 <- table(dtf[,col1], exclude=opt, dnn=cn[col1]) tbl2 <- addmargins(tbl1, 1) pct1 <- get.pct(tbl1)$pct1 pct2 <- NULL } res <- list(tbl1=tbl1, tbl2=tbl2, pct1=pct1, pct2=pct2) for (i in 1:length(res)) res[[i]] <- rename.item(res[[i]], c(NA,"Sum"), c("無効回答","総数")) return(res) } # 無効回答を含めた集計 # dtf:データフレーム、col1:着目列1、col2:着目列2 sa2 <- function(dtf, col1, col2=NULL) { return(sa1(dtf, col1, col2, NULL)) } # 有効回答(小計)を含めた集計 # dtf:データフレーム、col1:着目列1、col2:着目列2 sa3 <- function(dtf, col1, col2=NULL) { ww <- sa2(dtf, col1, col2) if (is.null(ww)) return(NULL) if (!is.null(col2)) { xx <- ww$tbl2 n <- ncol(xx) # 列の個数 yy <- xx[,n] - xx[,n-1] # 有効回答数を算出 zz <- cbind(xx[,1:(n-2)], 有効回答=yy, xx[,(n-1):n]) xx <- zz n <- nrow(xx) # 行の個数 yy <- xx[n,] - xx[n-1,] # 有効回答数を算出 tbl <- as.table(rbind(xx[1:(n-2),], 有効回答=yy, xx[(n-1):n,])) nc <- ncol(tbl) nr <- nrow(tbl) pct1 <- tbl for (i in 1:nr) { if (pct1[i,nc] == 0) next pct1[i,] <- pct1[i,] / pct1[i,nc] * 100 } pct2 <- tbl for (i in 1:nc) { if (pct2[nr,i] == 0) next pct2[,i] <- pct2[,i] / pct2[nr,i] * 100 } } else { # 1列のみの指定 dnn <- names(ww$tbl2) xx <- as.vector(ww$tbl2) n <- length(xx) # 列の個数 yy <- xx[n] - xx[n-1] # 有効回答数を算出 tbl <- c(xx[1:(n-2)], yy, xx[(n-1):n]) names(tbl) <- c(dnn[1:(n-2)], "有効回答", dnn[(n-1):n]) nc <- length(tbl) pct1 <- tbl for (i in 1:nc) { if (pct1[nc] == 0) next pct1[i] <- pct1[i] / pct1[nc] * 100 } tbl <- as.table(tbl) pct1 <- as.table(pct1) pct2 <- NULL } res <- list(tbl1=tbl, tbl2=NULL, pct1=pct1, pct2=pct2) res <- rename.dnn(res, names(dimnames(ww[[1]]))) return(res) } # 複数回答の列をfactorとして再設定 # dtf:データフレーム、mm:着目列、lvl:levels、lbl:labels ma.refactor <- function(dtf, mm, lvl, lbl=NULL) { cn <- colnames(dtf) mm <- get.col(cn, mm) if (length(mm) == 0) { warning("列名または列番号の指定が不適当です") return(NULL) } if (!(is.vector(lvl) && length(lvl) == 2)) { warning("第3引数(levels)の指定が不適当です") return(NULL) } excl <- if (length(lvl[is.na(lvl)])>0) NULL else c(NA) for (i in mm) { if (is.null(lbl)) w <- c(sprintf("%s○",cn[i]), sprintf("%s×",cn[i])) else w <- lbl dtf[,i] <- factor(dtf[,i], levels=lvl, labels=w, exclude=excl) } return(dtf) } # 複数回答の選択個数を算出 # dtf:データフレーム、mm:着目列、ptn:「選択あり」を示すパターン、 # add.flag:選択個数をnnnとしてdtfに追加するか否かのフラグ(FALSE|TRUE) ma.count <- function(dtf, mm, ptn=1, add.flag=FALSE) { cn <- colnames(dtf) mm <- get.col(cn, mm) if (length(mm) == 0) { warning("列名または列番号の指定が不適当です") return(NULL) } w <- as.character(ptn) if (!is.character(w)) { warning("第3引数(選択ありを示すパターン)の指定が不適当です") return(NULL) } nr <- nrow(dtf) count <- rep(0, nr) for (i in 1:nr) { w <- dtf[i,mm] w <- w[!is.na(w)] if (length(w) == 0) { count[i] <- 0 next } if (is.character(ptn)) { w <- as.character(w) count[i] <- length(grep(ptn,w)) } else count[i] <- length(w[w==ptn]) } if (!add.flag) return(count) count.name <- "nnn" # 選択個数の列名 if (length(which(cn == count.name)) > 0) dtf[,count.name] <- count else { dtf <- cbind(dtf, count) colnames(dtf) <- c(cn, count.name) } return(dtf) } # 複数回答と単一回答の組合せ集計 # dtf:データフレーム、i:着目列1、j:着目列2 # i|jのどちらかは単一回答、他方は複数回答 ma1 <- function(dtf, i, j) { check_column <- function(cn, j) { flag <- TRUE for (k in j) { if (!is.factor(dtf[,k])) { warning(sprintf("列 '%s' は factor でなければなりません", cn[k])) flag <- FALSE next } if (nlevels(dtf[,k]) != 2) { warning(sprintf("列 '%s' は2値データでなければなりません", cn[k])) flag <- FALSE } } return(flag) } cn <- colnames(dtf) i <- get.col(cn, i) j <- get.col(cn, j) if (length(i) == 1 && length(j) > 1) row <- TRUE else if (length(i) > 1 && length(j) == 1) { row <- FALSE temp <- i i <- j j <- temp } else { warning("複数回答と単一回答の組合せになっていません") return(NULL) } if (!check_column(cn,j)) return(NULL) dtf.i <- as.factor(dtf[,i]) ans <- sapply(j, function(k) table(dtf[,i], dtf[,k]))[1:nlevels(dtf.i),] ans <- cbind(ans, table(dtf.i)) ans <- rbind(ans, colSums(ans)) rownames(ans) <- c(levels(dtf.i), "合計") colnames(ans) <- c(colnames(dtf[,j]), "該当数") nc <- ncol(ans) pct <- ans/ans[,nc]*100 if (!row) { ans <- t(ans) pct <- t(pct) } res <- list(tbl=ans, pct=pct) return(res) } # 複数回答の選択肢相互の関係に関する全体像 # dtf:データフレーム、mm:着目列(複数回答に関する複数個の列) ma2 <- function(dtf, mm) { cn <- colnames(dtf) mm <- get.col(cn, mm) if (length(mm) == 0) { warning("列名または列番号の指定が不適当です") return(list(NULL, NULL, NULL, NULL)) } l <- length(mm) tbl1 <- matrix(FALSE, l, l) # l行・l列の行列を用意 colnames(tbl1) <- cn[mm] rownames(tbl1) <- cn[mm] for (i in 1:l) { for (j in i:l) { xx <- table(dtf[,mm[i]], dtf[,mm[j]]) tbl1[i,j] <- xx[1,1] if (!tbl1[j,i]) tbl1[j,i] <- xx[1,1] } } ss <- sapply(1:l, function(i) tbl1[i,i]) tbl2 <- cbind(tbl1, 該当数=ss) ss <- c(ss, nrow(dtf)) tbl2 <- rbind(tbl2, 該当数=ss) l <- l + 1 pct1 <- tbl2 for (i in 1:l) { ss <- tbl2[i,i] if (ss == 0) next for (j in 1:l) { pct1[i,j] <- tbl2[i,j] / ss * 100.0 } } pct2 <- NULL ss <- nrow(dtf) if (!is.na(ss) && ss > 0) { pct2 <- tbl2 for (i in 1:l) { for (j in 1:l) { pct2[i,j] <- tbl2[i,j] / ss * 100.0 } } } res <- list(tbl1=tbl1, tbl2=tbl2, pct1=pct1, pct2=pct2) return(res) } # 標本分散 var2 <- function(x) { x <- x[!is.na(x)] n <- length(x) return(var(x)*(n-1)/n) } # 標本標準偏差 sd2 <- function(x) { x <- x[!is.na(x)] n <- length(x) return(sqrt(var(x)*(n-1)/n)) } # 数値データについて、1つの値を返す関数の集計 # dtf:データフレーム、ctg:単一回答の列、val:数値データの列、fun:関数 va1 <- function(dtf, ctg, val, fun=mean) { check_column <- function(ctg, val) { flag <- TRUE if (!is.factor(dtf[,ctg])) { warning(sprintf("列 '%s' は factor でなければなりません", ctg)) flag <- FALSE } for (v in val) { if (is.factor(dtf[,v]) || is.character(dtf[,v])) { warning(sprintf("列 '%s' が factor|character なのは不適当です", v)) flag <- FALSE } } return(flag) } cn <- colnames(dtf) ctg <- get.col(cn, ctg, "c") val <- get.col(cn, val, "c") if (length(ctg) == 0 || length(val) == 0) { warning("列名または列番号の指定が不適当です") return(NULL) } if (length(ctg) > 1 && length(val) == 1) { temp <- ctg ctg <- val val <- temp } if (!(length(ctg) == 1 && length(val) >= 1)) { warning("列名または列番号の指定が不適当です") return(NULL) } if (!check_column(ctg, val)) return(NULL) xx <- sapply(val, function(i) tapply(dtf[,i], dtf[,ctg], fun)) ww <- sapply(val, function(i) fun(dtf[,i])) res <- rbind(xx, 全体=ww) colnames(res) <- val return(res) } # 数値データについて、複数の値を返す関数の集計 # dtf:データフレーム、ctg:単一回答の列、val:数値データの列、fun:関数 va2 <- function(dtf, ctg, val, fun=summary) { check_column <- function(ctg, val) { flag <- TRUE if (!is.factor(dtf[,ctg])) { warning(sprintf("列 '%s' は factor でなければなりません", ctg)) flag <- FALSE } for (v in val) { if (is.factor(dtf[,v]) || is.character(dtf[,v])) { warning(sprintf("列 '%s' が factor|character なのは不適当です", v)) flag <- FALSE } } return(flag) } cn <- colnames(dtf) ctg <- get.col(cn, ctg, "c") val <- get.col(cn, val, "c") if (length(ctg) > 1 && length(val) == 1) { temp <- ctg ctg <- val val <- temp } if (!(length(ctg) == 1 && length(val) >= 1)) { warning("列名または列番号の指定が不適当です") return(NULL) } if (!check_column(ctg, val)) return(NULL) xx <- lapply(val, function(i) tapply(dtf[,i], dtf[,ctg], fun)) names(xx) <- val cc <- levels(dtf[,ctg]) yy <- lapply(val, function(i) sapply(cc, function(j) xx[[i]][[j]])) names(yy) <- val ww <- lapply(val, function(i) fun(dtf[,i])) names(ww) <- val res <- lapply(val, function(i) t(cbind(yy[[i]], 全体=ww[[i]]))) names(res) <- val return(res) } # 日付データのカテゴリー化(年・月・日・四半期・曜日の5種類) # dtf: データフレーム、cc: Date型データの列 # xtype:新設の列を数値vector(n) | factor(c)のどちらにするかの選択 date.split <- function(dtf, cc, xtype="c") { cn <- colnames(dtf) cc <- get.col(cn, cc) if (length(cc) == 0) { warning("列名または列番号の指定が不適当です") return(NULL) } date.dat <- dtf[,cc] if (class(date.dat) != "Date") { warning("Date型を指定して下さい") return(NULL) } if (xtype == "character") xtype <- "c" else if (xtype == "numeric") xtype <- "n" if (xtype != "c" && xtype != "n") xtype <- "c" cname <- c("year", "month", "mday", "quarter", "wday") nn <- seq_along(cn)[cn %in% cname] if (length(nn) > 0) # dtf中に既に year, month などの列がある cname <- sapply(cname, function(i) sprintf("%s%d", i, cc)) fmt <- c("%s年", "%s月", "%s日", "第%s四半期") wname <- c("日曜日","月曜日","火曜日","水曜日","木曜日","金曜日","土曜日") ymd <- t(sapply(format(date.dat, "%Y-%m-%d"), function(ss) as.numeric(unlist(strsplit(ss, "-"))))) qq <- as.numeric(cut(ymd[,2], breaks=c(1,4,7,10,13), labels=1:4, right=F)) ww <- weekdays(date.dat) for (i in 1:length(wname)) ww[ww==wname[i]] <- i dd <- data.frame(cbind(ymd, qq, ww)) colnames(dd) <- cname if (xtype == "c") { for (i in 1:(ncol(dd)-1)) { # 年・月・日・四半期のfactor化 dd[,i] <- as.factor(dd[,i]) lvl <- levels(dd[,i]) lbl <- sapply(lvl, function(j) sprintf(fmt[i],j)) dd[,i] <- factor(dd[,i], levels=lvl, labels=lbl) } dd[,ncol(dd)] <- factor(ww, levels=1:7, labels=wname) # 曜日のfactor化 } for (i in cname) dtf[,i] <- NULL # 重複する列名を削除 return(cbind(dtf, dd)) }