Merge branch 'improve-codefactor' into cran-prep

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: smms
 Title: Semi-Markov Multi-State Models for Interval Censored Data
-Version: 0.0.1.9002
+Version: 1.0.0.9001
 Date: 2024-03-12
 Authors@R:
     c(
@@ -37,7 +37,7 @@ License: MIT + file LICENSE
 Encoding: UTF-8
 LazyData: true
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.3.1
+RoxygenNote: 7.3.2
 Imports:
     igraph,
     parallel,

NEWS.md

@@ -1,3 +1,7 @@
 # smms (development version)
 
+* Fixed code smells.
+
+# smms 1.0.0
+
 * Initial CRAN submission.

R/sm_msm_latex_func.R

@@ -24,7 +24,7 @@ write_type <- function(obs_type,graph,abs_exact=TRUE){
   f_types = names(which(formula_obs_types[, obs_type] == 1))
   lik_parts <- rep(NA,length(f_types))
 
-  for (k in 1:length(f_types)){
+  for (k in seq_along(f_types)){
     form_type=f_types[k]
 
     integrand = type_to_integrand(form_type,edge_mats, names_surv_dens,abs_exact=abs_exact)
@@ -96,14 +96,14 @@ write_type <- function(obs_type,graph,abs_exact=TRUE){
 
     m <- gregexpr("[fS]_[[:digit:]]{2}",int)
     call <- regmatches(int,m)
-    for (i in 1:length(call[[1]])){
+    for (i in seq_along(call[[1]])){
       callspl <- unlist(strsplit(call[[1]][i],""))
       int <- gsub(call[[1]][i],paste(callspl[1],"_{",paste(callspl[3:4],collapse=""),"}",sep=""),int)
     }
 
     # Make timepoints (belonging to the obs_type)
-    timepoints = c()
-    for (i in 1:length(otype_splt)){
+    timepoints = NULL
+    for (i in seq_along(otype_splt)){
       st <- as.numeric(otype_splt[i])
       if (state_ord$type[which(state_ord$order==st)]=="trans"){
         ti <- c(paste("t_{",st,"m}",sep=""),paste("t_{",st,"M}",sep=""))
@@ -129,20 +129,20 @@ write_type <- function(obs_type,graph,abs_exact=TRUE){
           next_state <- splitted_f_type[j+1]
           if (next_state %in% jump_states & (current_state %in% jump_states)){
             lower[j] <- 0
-            id_up <- which(1:length(timepoints)%in%seq(2,20,2) & as.numeric(substr(timepoints,4,4))>as.numeric(next_state))
+            id_up <- which(seq_along(timepoints)%in%seq(2,20,2) & as.numeric(substr(timepoints,4,4))>as.numeric(next_state))
             upper[j] <- paste(timepoints[min(id_up)],add_ons[j-1],sep="")
           }else if (next_state %in% jump_states & !(current_state %in% jump_states)){
-            id_low <- which(1:length(timepoints)%in%seq(1,19,2) & as.numeric(substr(timepoints,4,4))==as.numeric(current_state))
-            id_up <- which(1:length(timepoints)%in%seq(2,20,2) & as.numeric(substr(timepoints,4,4))>as.numeric(next_state))
+            id_low <- which(seq_along(timepoints)%in%seq(1,19,2) & as.numeric(substr(timepoints,4,4))==as.numeric(current_state))
+            id_up <- which(seq_along(timepoints)%in%seq(2,20,2) & as.numeric(substr(timepoints,4,4))>as.numeric(next_state))
             lower[j] <- paste(timepoints[id_low],add_ons[j-1],sep="")
             upper[j] <- paste(timepoints[min(id_up)],add_ons[j-1],sep="")
           }else if (!(next_state %in% jump_states) & (current_state %in% jump_states)){
             lower[j] <- 0
-            id_up <- which(1:length(timepoints)%in%seq(2,20,2) & as.numeric(substr(timepoints,4,4))==as.numeric(next_state))
+            id_up <- which(seq_along(timepoints)%in%seq(2,20,2) & as.numeric(substr(timepoints,4,4))==as.numeric(next_state))
             upper[j] <- paste(timepoints[min(id_up)],add_ons[j-1],sep="")
           }else{
-            id_low <- which(1:length(timepoints)%in%seq(1,19,2) & as.numeric(substr(timepoints,4,4))==as.numeric(current_state))
-            id_up <- which(1:length(timepoints)%in%seq(2,20,2) & as.numeric(substr(timepoints,4,4))==as.numeric(next_state))
+            id_low <- which(seq_along(timepoints)%in%seq(1,19,2) & as.numeric(substr(timepoints,4,4))==as.numeric(current_state))
+            id_up <- which(seq_along(timepoints)%in%seq(2,20,2) & as.numeric(substr(timepoints,4,4))==as.numeric(next_state))
             lower[j] <- paste(timepoints[id_low],add_ons[j-1],sep="")
             upper[j] <- paste(timepoints[id_up],add_ons[j-1],sep="")
           }
@@ -192,7 +192,7 @@ write_loglikelihood <- function(graph,abs_exact=TRUE){
   o_types <- construct_obs_types(graph)
   all_parts <- rep(NA,length(o_types))
 
-  for (i in 1:length(all_parts)){
+  for (i in seq_along(all_parts)){
     all_parts[i] <- write_type(obs_type=o_types[i],graph=graph,abs_exact=abs_exact)
   }
   eq <- paste("\\begin{align*} \n \\ell_n (\\theta)= ",paste(all_parts,collapse=" + "),". \n \\end{align*}")

R/sm_msm_likelihood_func.R

@@ -27,7 +27,7 @@ names_of_survival_density = function(graph){
 
   matrix_names = as.data.frame(matrix(ncol = 6, nrow = length(edge_names)))
   colnames(matrix_names) = c("edge_name","survival_name", "density_name", "from_prev", "to_prev", "type")
-  for(i in 1:length(edge_names)){
+  for(i in seq_along(edge_names)){
     kk_to = which(state_ord$state %in% all_edges[i,2])
     matrix_names[i, "survival_name"] = paste(c("S_", edge_names[i]), collapse = "")
     matrix_names[i, "density_name"] = paste(c("f_", edge_names[i]), collapse = "")
@@ -36,7 +36,7 @@ names_of_survival_density = function(graph){
     matrix_names[i, "edge_name"] = edge_names[i]
     matrix_names[i, "type"] = state_ord[kk_to, "type"]
   }
-  return(matrix_names)
+  matrix_names
 }
 
 #' Write out the integrand as a string
@@ -344,7 +344,7 @@ change_integrand <- function(integr){
       int <- sub("\\{.+?f_","\\{\nss<-times[1]\nf_",int) #sub("\\{.+f_","\\{\nss<-times[1]\nf_01",int)
     }
   }
-  return(eval(parse(text=int)))
+  eval(parse(text=int))
 }
 
 
@@ -404,7 +404,7 @@ finding_limits <- function(timepoints,form_type,edge_mats,absorbing_states,abs_e
     #id_na <- which(is.na(M_times) & substr(names(M_times),2,2)%in%unobs_states) #in unobs unecessary?
     id_na <- which(is.na(M_times))
     if (length(id_na)>0){
-      for (j in 1:length(id_na)){  ## CHECK
+      for (j in seq_along(id_na)){  ## CHECK
         M_times[id_na[j]] <- M_times[id_na[j]-1]
       }
     }
@@ -464,7 +464,7 @@ finding_limits <- function(timepoints,form_type,edge_mats,absorbing_states,abs_e
 mloglikelihood <-  function(param,integrands,limits, X = NULL,cmethod = "hcubature",mc_cores = 2){
   # Test that limits and integrand have same length
 
-  final_integral = sum(unlist(parallel::mclapply(1:length(integrands), function(i){
+  final_integral = sum(unlist(parallel::mclapply(seq_along(integrands), function(i){
     mm <- length(limits[[i]])
     lli <- rep(NA,mm)
     for (j in 1:mm){
@@ -486,13 +486,12 @@ mloglikelihood <-  function(param,integrands,limits, X = NULL,cmethod = "hcubatu
             },error=function(cond){
               integrand2 <- change_integrand(integrands[[i]][[j]])
               if (length(unique(lower)) != length(lower)){
-                llij = cubature::cubintegrate(integrand2, lower = lower,upper = upper, method = "divonne", maxEval = 500,
+                cubature::cubintegrate(integrand2, lower = lower,upper = upper, method = "divonne", maxEval = 500,
                                       tt = tmax[1], tt2=tmax[2],param = param, x = X[i,])$integral
               }else if (length(unique(lower)) == length(lower)){
-                llij = cubature::cubintegrate(integrand2, lower = lower,upper = upper,maxEval = 500,
+                cubature::cubintegrate(integrand2, lower = lower,upper = upper,maxEval = 500,
                                       method = cmethod, tt = tmax[1], tt2=tmax[2],param = param, x = X[i,])$integral
               }
-              return(llij)
             })
 
         }else if (length(lower)>2){

R/sm_msm_optim_func.R

@@ -42,12 +42,12 @@ smms = function(startval, data, graph, X = NULL, abs_exact=TRUE, mc_cores = 1, h
   all_integral_limits = list()
   integrand = list()
 
-  for(i in 1:nrow(all_data_set)){
+  for(i in seq_len(nrow(all_data_set))){
     observation_type[i] = all_data_set[i,"obs_type"]
     f_types = names(which(formula_obs_types[, observation_type[i]] == 1))
     integrand_mellomregn = list()
     integral_mellomregn= list()
-    for(j in 1:length(f_types)){
+    for(j in seq_along(f_types)){
       integrand_mellomregn[[j]] = eval(parse(text=type_to_integrand(f_types[j], edge_mats, names_surv_dens,abs_exact=abs_exact)))
       integral_mellomregn[[j]] = finding_limits(timepointMat[i,],f_types[j],edge_mats,absorbing_states,abs_exact=abs_exact)
     }
@@ -115,12 +115,12 @@ hessian_matrix = function(param, data, graph, X = NULL, mc_cores = 1,cmethod = "
   all_integral_limits = list()
   integrand = list()
 
-  for(i in 1:nrow(all_data_set)){
+  for(i in seq_len(nrow(all_data_set))){
     observation_type[i] = all_data_set[i,"obs_type"]
     f_types = names(which(formula_obs_types[, observation_type[i]] == 1))
     integrand_mellomregn = list()
     integral_mellomregn= list()
-    for(j in 1:length(f_types)){
+    for(j in seq_along(f_types)){
       integrand_mellomregn[[j]] = eval(parse(text=type_to_integrand(f_types[j], edge_mats, names_surv_dens)))
       integral_mellomregn[[j]] = finding_limits(timepointMat[i,],f_types[j],edge_mats,absorbing_states)
     }
@@ -216,9 +216,8 @@ occupancy_prob = function(state, time, param, graph, xval = NULL){
                          x = xval)
           },error=function(cond){
             integrand2 <- change_integrand(integrand)
-            llij = cubature::cubintegrate(integrand2, lower = lower,upper = upper, method = "divonne", maxEval = 500,
+            cubature::cubintegrate(integrand2, lower = lower,upper = upper, method = "divonne", maxEval = 500,
                                   tt = tmax[1], tt2=tmax[2],param = param, x = xval)$integral
-            return(llij)
           })
 
         }else if (length(lower)>2){
@@ -318,8 +317,7 @@ occupancy_prob_delta = function(state, time, param, graph, xval = NULL){
             pracma::grad(repintegrate,x0=param,innerfunc=integrand,tt=tmax[1],tt2=tmax[2],lower=lower,upper = upper,x = xval)
           },error=function(cond){
             integrand2 <- change_integrand(integrand)
-            llij = pracma::grad(cubint,x0=param,integrand=integrand2,lower = lower,upper = upper, tmax=tmax,xval=xval)
-            return(llij)
+            pracma::grad(cubint,x0=param,integrand=integrand2,lower = lower,upper = upper, tmax=tmax,xval=xval)
           })
 
         }else if (length(lower)>2){
@@ -562,9 +560,8 @@ transition_prob = function(trans_ji, time_t,time_v, param, graph, xval = NULL){
                          x = xval)
           },error=function(cond){
             integrand2 <- change_integrand(integrand)
-            llij = cubature::cubintegrate(integrand2, lower = lower,upper = upper, method = "divonne", maxEval = 500,
+            cubature::cubintegrate(integrand2, lower = lower,upper = upper, method = "divonne", maxEval = 500,
                                           tt = tmax[1], tt2=tmax[2],param = param, x = xval)$integral
-            return(llij)
           })
 
         }else if (length(lower)>2){
@@ -685,8 +682,7 @@ transition_prob_delta = function(trans_ji, time_t,time_v, param, graph, xval = N
             pracma::grad(repintegrate,x0=param,innerfunc=integrand,tt=tmax[1],tt2=tmax[2],lower=lower,upper = upper,x = xval)
           },error=function(cond){
             integrand2 <- change_integrand(integrand)
-            llij = pracma::grad(cubint,x0=param,integrand=integrand2,lower = lower,upper = upper, tmax=tmax,xval=xval)
-            return(llij)
+            pracma::grad(cubint,x0=param,integrand=integrand2,lower = lower,upper = upper, tmax=tmax,xval=xval)
           })
 
         }else if (length(lower)>2){

R/sm_msm_preprocessing_func.R

@@ -54,7 +54,7 @@ state_ordering = function(graph){
 
   state_num$order[which(state_num$state %in% absorbing_states)] <- (k-1-length(absorbing_states)+1):(k-1)
   state_num$type[which(state_num$state %in% absorbing_states)] <- "abs"
-  return(state_num)
+  state_num
 }
 
 #' Filter away redundant observations in a multi-state dataset
@@ -107,7 +107,7 @@ relevant_timepoints = function(data, graph){
 
     rle_i <- rle(ddi$state)
     id_unrelevant = NULL
-    for(j in 1:length(rle_i$values)){
+    for(j in seq_along(rle_i$values)){
       val <- rle_i$values[j]
       num <- rle_i$lengths[j]
       if(val%in%init & num >= 2){ #initial states
@@ -121,7 +121,7 @@ relevant_timepoints = function(data, graph){
     idd = c(idd,which(ddr$patient==inds[i])[id_unrelevant])
   }
   if (length(idd)>0) ddr = ddr[-idd,]
-  return(ddr)
+  ddr
 }
 
 #' Find all formula types
@@ -146,23 +146,22 @@ construct_formula_types = function(graph){
   subsets[,2] <- rep(c(init,trans,abs),times=length(init))
 
   ## Determine which subsets containt none, one or multiple paths
-  form_types = c()
-  for(p in 1:nrow(subsets)){
+  form_types = NULL
+  for(p in seq_len(nrow(subsets))){
     paths = igraph::all_simple_paths(graph, state_ord$state[which(state_ord$order==subsets[p,1])],
                              state_ord$state[which(state_ord$order==subsets[p,2])])
     ## If only observed in initial state
     if(length(paths) == 0){
       form_types = c(form_types, as.character(subsets[p, 1]))
     } else{ ## For all the other possible roads to travel
-      for(i in 1:length(paths)){
+      for(i in seq_along(paths)){
         st = sort(state_ord$order[which(state_ord$state%in%igraph::as_ids(paths[[i]]))])
         data_frame_subset_type_as_char = paste(st, collapse = "")
         form_types = c(form_types, data_frame_subset_type_as_char)
       }
     }
   }
-  form_types = unique(form_types)
-  return(form_types)
+  unique(form_types)
 }
 
 
@@ -176,18 +175,17 @@ construct_formula_types = function(graph){
 #' @return A vector with string elements indicating the states in which the patient is observed.
 construct_obs_types = function(graph){
   form_types = construct_formula_types(graph)
-  obs_types = c()
-  for (i in 1:length(form_types)){
+  obs_types = NULL
+  for (i in seq_along(form_types)){
     st = strsplit(form_types[i],"")[[1]]
     obs_types = c(obs_types,form_types[i])
     if (length(st)>2){
-      ot = sapply(2:(length(st)-1), function(r) utils::combn(st[1:length(st)],r),simplify=F)
+      ot = sapply(2:(length(st)-1), function(r) utils::combn(st[seq_along(st)],r),simplify=F)
       ot = lapply(ot,function(m) m[,which(m[1,]==st[1])])
       obs_types = c(obs_types,unlist(lapply(ot,function(m) apply(m,2,paste,collapse=""))))
     }
   }
-  obs_types = unique(obs_types)
-  return(obs_types)
+  unique(obs_types)
 }
 
 #' Find links between formula and observation types
@@ -204,9 +202,9 @@ all_types = function(graph){
   matrix_all_types = matrix(data = 0, nrow = length(formula_types), ncol = length(observation_types))
   rownames(matrix_all_types) = formula_types
   colnames(matrix_all_types) = observation_types
-  for(i in 1:length(formula_types)){
+  for(i in seq_along(formula_types)){
     formula_types_split = unlist(strsplit(formula_types[i], ""))
-    for(j in 1:length(observation_types)){
+    for(j in seq_along(observation_types)){
       observation_types_split = unlist(strsplit(observation_types[j], ""))
       if(formula_types_split[1] == observation_types_split[1] &
          formula_types_split[length(formula_types_split)] == observation_types_split[length(observation_types_split)] &
@@ -215,7 +213,7 @@ all_types = function(graph){
       }
     }
   }
-  return(matrix_all_types)
+  matrix_all_types
 }
 
 #' Arrange data set
@@ -260,7 +258,7 @@ arrange_data = function(data, graph){
     ## Which observed type the individual is
     timepoints[i, ncol(timepoints)] = paste(unique(names(tti[!(is.na(tti))])), collapse ="")
   }
-  return(timepoints)
+  timepoints
 }
 
 #' Make edge matrices
@@ -286,7 +284,7 @@ edge_matrices = function(graph){
   matrix_travelled = matrix(data = 0, nrow = length(formula_types), ncol = length(edge_names))
   rownames(matrix_travelled) = formula_types
   colnames(matrix_travelled) = edge_names
-  for(i in 1:length(formula_types)){
+  for(i in seq_along(formula_types)){
     formula_str_pairs = substring(formula_types[i], first = 1:(nchar(formula_types[i]) - 1), last = 2:nchar(formula_types[i]))
     matches = which(edge_names %in% formula_str_pairs)
     matches_order = match(edge_names[matches],formula_str_pairs)
@@ -298,7 +296,7 @@ edge_matrices = function(graph){
   matrix_possible_next = matrix(data = 0, nrow = length(formula_types), ncol = length(edge_names))
   rownames(matrix_possible_next) = formula_types
   colnames(matrix_possible_next) = edge_names
-  for(i in 1:length(formula_types)){
+  for(i in seq_along(formula_types)){
     formula_types_split = unlist(strsplit(formula_types[i], ""))
     id_next <- which(all_edges[,1]==formula_types_split[length(formula_types_split)])
     if (length(id_next)==0) next
@@ -309,15 +307,14 @@ edge_matrices = function(graph){
   matrix_passed = matrix(data = 0, nrow = length(formula_types), ncol = length(edge_names))
   rownames(matrix_passed) = formula_types
   colnames(matrix_passed) = edge_names
-  for(i in 1:length(formula_types)){
+  for(i in seq_along(formula_types)){
     formula_str_pairs = substring(formula_types[i], first = 1:(nchar(formula_types[i]) - 1), last = 2:nchar(formula_types[i]))
-    for (j in 1:length(formula_str_pairs)){
+    for (j in seq_along(formula_str_pairs)){
       pair_split = unlist(strsplit(formula_str_pairs[j], ""))
       match_passed = which(pair_split[1]==all_edges[,1] & pair_split[2]!=all_edges[,2])
       if (length(match_passed)==0) next
       matrix_passed[i,match_passed] = j
     }
   }
-  list_all_edges = list("traveled" = matrix_travelled , "passedBy" = matrix_passed, "possible" = matrix_possible_next)
-  return(list_all_edges)
+  list("traveled" = matrix_travelled , "passedBy" = matrix_passed, "possible" = matrix_possible_next)
 }