HEX
Server: Apache/2.4.46 (Win64) OpenSSL/1.1.1j PHP/8.4.25
System: Windows NT DESKTOP-4TAV2RJ 10.0 build 19045 (Windows 10) AMD64
User: fred (0)
PHP: 8.4.25
Disabled: NONE
Upload Files
File: C:/Program Files/R/R-4.4.0/library/survival/tests/ratetable.R
options(na.action=na.exclude) # preserve missings
options(contrasts=c('contr.treatment', 'contr.poly')) #ensure constrast type
library(survival)

#
# Generate each of the messages from is.ratetable
#
mdy.date <- function(m, d, y) {
    y <- ifelse(y<100, y+1900, y)
    as.Date(paste(m,d,y, sep='/'), "%m/%d/%Y")
    }
temp <- runif(21*2*4)

# Good
attributes(temp) <- list(dim=c(21,2,4),
    dimnames=list(c(as.character(75:95)), c("male","female"),
                  c(as.character(2000:2003))),
    dimid=c("age","sex","year"),
    type=c(2,1,4),
    cutpoints=list(c(75:95), NULL, mdy.date(1,1,2000) +c(0:3)*366.25),
    class='ratetable')
is.ratetable(temp)

# Factor problem + cutpoints length
attributes(temp) <- list(dim=c(21,2,4),
    dimnames=list(c(as.character(75:95)), c("male","female"),
                  c(as.character(2000:2003))),
    dimid=c("age","sex","year"),
    type=c(1,1,2),
    cutpoints=list(c(75:95), NULL, mdy.date(1,1,2000) +c(0:4)*366.25),
    class='ratetable')
is.ratetable(temp, verbose=T)
 
                    
# missing dimid attribute + unsorted cutpoint
attributes(temp) <- list(dim=c(21,2,4),
    dimnames=list(c(as.character(75:95)), c("male","female"),
                  c(as.character(2000:2003))),
    type=c(2,1,3),
    cutpoints=list(c(75:95), NULL, mdy.date(1,1,2000) +c(4:1)*366.25),
    class='ratetable')
is.ratetable(temp, verbose=T)

# wrong length for dimid and type, illegal type
attributes(temp) <- list(dim=c(21,2,4),
    dimnames=list(c(as.character(75:95)), c("male","female"),
                  c(as.character(2000:2003))),
    dimid=c("age","sex","year", "zed"),
    type=c(2,1,3,6),
    cutpoints=list(c(75:95), NULL, mdy.date(1,1,2000) +c(0:3)*366.25),
    class='ratetable')
is.ratetable(temp, verbose=T)


# Print and summary
print(survexp.us[1:20,,c('1953', '1985')] )
summary(survexp.usr)